;;--------------------------------------------------------------------------
;; AriNET Project in Informatics IA by Dominique Guinard
;; dominique.guinard@unifr.ch
;;--------------------------------------------------------------------------
;; prefix->arinet
;;--------------------------------------------------------------------------
; ------------------------------------------------------------
; ABSTRACT:
; *********
; This is function handels the converting of constraints
; (and modules) into arithmetical networks, using the
; "boxes" (objects) defined in arinet.scm
; ------------------------------------------------------------
;(load "myeval.scm")
(define (prefix->arinet expr env)
(let ((current (my-first expr)))
(cond ((ari-number? current) (ari-eval-number current env))
((ari-equation? current) (ari-eval-equation expr env))
((ari-1ary? current) (ari-eval-1ary expr env))
((ari-2ary? current) (ari-eval-2ary expr env))
((ari-module? current) (ari-eval-module expr env))
((ari-variable? current)
(ari-eval-variable current env))
(else (errormsg "Unknown AriNET command" 'user)))))
;;--------------------------------------------------------------------------
;; end of prefix->arinet
;;--------------------------------------------------------------------------
; ------------------------------------------------------------
; Ari-evals
; ------------------------------------------------------------
(define (ari-eval-number number env)
; note : sending back the "me" procedure issued of the (make-variable)
; and not of the (constant) because the one of the constant is empty !
; (see arinet.scm for more info)
(let ((x (make-variable)))
(constant number x)
x))
(define (ari-eval-variable variable env)
(lookup-variable-value variable env))
(define (ari-eval-equation expr env)
(equalizer (prefix->arinet (left-expr expr) env)
(prefix->arinet (right-expr expr) env)))
(define (ari-eval-1ary expr env)
(let ((x (make-variable)))
(cond ((eq? 'sqr (my-first expr))
(square (prefix->arinet (left-expr expr) env)
x))
((eq? 'sin (my-first expr))
(sinbox (prefix->arinet (left-expr expr) env)
x))
((eq? 'cos (my-first expr))
(cosbox (prefix->arinet (left-expr expr) env)
x))
((eq? 'tan (my-first expr))
(cosbox (prefix->arinet (left-expr expr) env)
x))
((eq? 'exp (my-first expr))
(expbox (prefix->arinet (left-expr expr) env)
x))
((eq? 'ln (my-first expr))
(let ((a (prefix->arinet (left-expr expr) env)))
(if (greater? (get-value a) 0)
(expbox x
a)
(errormsg "In the real number set, ln(x) is defined only for positive values." 'user))))
((eq? 'sqrt (my-first expr))
(let ((a (prefix->arinet (left-expr expr) env)))
(if (greater-or-equal? (get-value a) 0)
(square x
a)
(errormsg "In the real number set, sqrt(x) is defined only between [0..infinity[." 'user))))
((eq? 'arctan (my-first expr))
(tanbox x
(prefix->arinet (left-expr expr) env)))
((eq? 'arccos (my-first expr))
(let ((a (prefix->arinet (left-expr expr) env)))
(if (between-or-equal? (get-value a) -1 1)
(cosbox x
a)
(errormsg "In the real number set, arccos(x) is defined only between [-1..1]." 'user))))
((eq? 'arcsin (my-first expr))
(let ((a (prefix->arinet (left-expr expr) env)))
(if (between-or-equal? (get-value a) -1 1)
(sinbox x
a)
(errormsg "In the real number set, arcsin(x) is defined only between [-1..1]." 'user)))))
x))
(define (ari-eval-2ary expr env)
(let ((x (make-variable)))
(cond ((eq? '+ (my-first expr))
(adder (prefix->arinet (left-expr expr) env)
(prefix->arinet (right-expr expr) env)
x))
((eq? '* (my-first expr))
(multiplier (prefix->arinet (left-expr expr) env)
(prefix->arinet (right-expr expr) env)
x))
((eq? '/ (my-first expr))
(let ((a (prefix->arinet (left-expr expr) env))
(b (prefix->arinet (right-expr expr) env)))
(if (eq? (get-value b) 0)
(errormsg "the division by 0 is unknown in the real number set." 'user)
(multiplier b
x
a))))
((eq? '- (my-first expr))
(adder (prefix->arinet (right-expr expr) env)
x
(prefix->arinet (left-expr expr) env))))
x))
(define (ari-eval-module expr env)
(my-apply (lookup-variable-value (module-name expr) env)
(map (lambda(x) (prefix->arinet x env))
(module-operands expr))))
; ------------------------------------------------------------
; Predicates
; ------------------------------------------------------------
(define (ari-number? expr)
(number? expr))
(define (atom? expr)
(not (pair? expr)))
(define (ari-variable? expr)
(variable? expr))
(define (ari-equation? expr)
(eq? '= expr))
(define (ari-1ary? expr)
(cond ((eq? 'sin expr) #t)
((eq? 'cos expr) #t)
((eq? 'tan expr) #t)
((eq? 'sqr expr) #t)
((eq? 'exp expr) #t)
((eq? 'ln expr) #t)
((eq? 'sqrt expr) #t)
((eq? 'arctan expr) #t)
((eq? 'arccos expr) #t)
((eq? 'arcsin expr) #t)
(else #f)))
(define (ari-2ary? expr)
(cond ((eq? '+ expr) #t)
((eq? '* expr) #t)
((eq? '/ expr) #t)
((eq? '- expr) #t)
(else #f)))
(define (greater? expr value)
(if (number? expr)
(> expr value)
#t))
(define (greater-or-equal? expr value)
(if (number? expr)
(>= expr value)
#t))
(define (between-or-equal? expr lower upper)
(if (number? expr)
(and (>= expr lower) (<= expr upper))
#t))
(define (ari-module? expr)
(member expr *MODULES*))
; ------------------------------------------------------------
; end of Predicates
; ------------------------------------------------------------
; ------------------------------------------------------------
; Selectors
; ------------------------------------------------------------
(define (my-first expr)
(if (atom? expr)
expr
(car expr)))
(define (left-expr expr)
(let ((current (car (cdr expr))))
(if (atom? current)
(list current)
current)))
(define (right-expr expr)
(let ((current (car (cdr (cdr expr)))))
(if (atom? current)
(list current)
current)))
(define (module-name expr)
(car expr))
(define (module-operands expr)
(cdr expr))
(define (accumulate-env op initial sequence env)
(if (null? sequence)
initial
(op env
(accumulate-env op initial (cdr sequence) env))))
; ------------------------------------------------------------
; end of Selectors
; ------------------------------------------------------------