;;--------------------------------------------------------------------------
;; AriNET Project in Informatics IA by Dominique Guinard
;; dominique.guinard@unifr.ch
;;--------------------------------------------------------------------------
;; arinet
;;--------------------------------------------------------------------------
; Autor: Lehmann Norbert + Jungo Dominik
; Modified by: Dominique Guinard
; Partly taken from the book: Structure of Computer
; Programs by Abelson Sussmann. (MIT Press)
; Datum: 28.10.2002
; Filename: arinet.scm
; ------------------------------------------------------------
; ABSTRACT:
; *********
; These functions are used to build an arithmetical network.
; They approach the oriented object programming as the
; differents "boxes" (sinbox, cosbox, adder), can
; be considered as objects with local state.
; ------------------------------------------------------------
;(require (lib "compile.ss"))
;(compile-file "Constraints.scm")
; ***********************************************************************
; DESCRIPTION: Creating an instance of a variable. A variable has among
; others a value. There exists several messages which
; allows the manipulation of this value.
(define currentvar '())
(define currentnew-value 0)
(define currentinformant '())
(define (make-variable)
(let ((value '())
(informant '())
(constraints '()))
(define (set-my-value! new-value setter)
(cond ((not (has-value? me))
(set! value new-value)
(set! informant setter)
(for-each-except setter inform-about-value constraints))
((> (abs (- value new-value)) eps)
(ErrorMsg (string-append "Contradiction "
(number->string value)
"="
(number->string new-value))
'user))
(else #t)))
(define (forget-my-value! retractor)
(cond ((or (equal? retractor informant)
(equal? retractor 'Passpartout))
(set! informant '())
(set! value '())
(for-each-except retractor
inform-about-no-value
constraints))
;note : this error is intentionaly not passed to the errorhandeler
;as it occurs sometimes even if there is no error.
(else "ERROR -- Unable to forget the value")))
(define (connect! new-constraint)
(if (not (memq new-constraint constraints))
(set! constraints (cons new-constraint constraints)))
(if (has-value? me)
(inform-about-value new-constraint)))
(define (deconnect! old-constraint)
(if (memq old-constraint constraints)
(set! constraints (remove old-constraint constraints))))
(define (deconnect-all!)
(set! constraints '())
(set! informant '())
(set! value '()))
(define (me request)
(cond ((equal? request 'has-value?) (not (null? informant)))
((equal? request 'value) value)
((equal? request 'set-value!) set-my-value!)
((equal? request 'forget) forget-my-value!)
((equal? request 'connect) connect!)
((equal? request 'connect) connect!)
((equal? request 'deconnect) deconnect!)
((equal? request 'deconnect-all) deconnect-all!)
(else (ErrorMsg "Unknown operation -- VARIABLE" 'code))))
me))
; ***********************************************************************
; DESCRIPTION: The following procedures are used to do the communication
; in an arithmetic network.
(define eps 0.000001)
(define (intern-set-value! var new-value informant)
((var 'set-value!) new-value informant))
(define (inform-about-value constraint)
((constraint 'i-have-a-value)))
(define (inform-about-no-value constraint)
((constraint 'i-lost-my-value)))
(define (set-value! var new-value informant)
(set! currentvar var)
(set! currentnew-value new-value)
(set! currentinformant informant)
((var 'set-value!) new-value informant))
(define (forget-value! var retractor)
((var 'forget) retractor))
(define (get-value var)
(var 'value))
(define (has-value? var)
(var 'has-value?))
(define (connect var new-constraint)
((var 'connect) new-constraint))
(define (deconnect var old-constraint)
((var 'deconnect) old-constraint))
(define (deconnect-all var)
((var 'deconnect-all)))
(define (for-each-except exception procedure list)
(define (loop items)
(cond ((null? items) "DONE -- AriNET command")
((equal? (car items) exception) (loop (cdr items)))
(else (procedure (car items)) (loop (cdr items)))))
(loop list))
; ***********************************************************************
; DESCRIPTION: The following functions like adder, multiplier, constant,
; sinbox, equalizer,... represent the function-boxes
; of an arithmetic network. They allow to connect
; variables together.
; ***********************************************************************
; (ADDER a1 a2 sum) -> a1 + a2 = sum
(define (adder a1 a2 sum)
(define (process-new-value)
(cond ((and (has-value? a1) (has-value? a2))
(intern-set-value! sum (+ (get-value a1) (get-value a2)) me))
((and (has-value? a1) (has-value? sum))
(intern-set-value! a2 (- (get-value sum) (get-value a1)) me))
((and (has-value? a2) (has-value? sum))
(intern-set-value! a1 (- (get-value sum) (get-value a2)) me))))
(define (process-forget-value)
(forget-value! sum me)
(forget-value! a1 me)
(forget-value! a2 me)
(process-new-value))
(define (me request)
(cond ((equal? request 'i-have-a-value) process-new-value)
((equal? request 'i-lost-my-value) process-forget-value)
(else (ErrorMsg "Unknown request -- ADDER" 'code))))
(connect a1 me)
(connect a2 me)
(connect sum me)
me)
; ***********************************************************************
; (MULTIPLIER m1 m2 product) -> m1 * m2 = product
(define (multiplier m1 m2 product)
(define (process-new-value)
(cond ((or (and (has-value? m1) (= (get-value m1) 0))
(and (has-value? m2) (= (get-value m2) 0)))
(intern-set-value! product 0 me))
((and (has-value? m1) (has-value? m2))
(intern-set-value! product
(* (get-value m1) (get-value m2))
me))
((and (has-value? m1) (has-value? product))
(intern-set-value! m2
(/ (get-value product) (get-value m1))
me))
((and (has-value? m2) (has-value? product))
(intern-set-value! m1
(/ (get-value product) (get-value m2))
me))))
(define (process-forget-value)
(forget-value! product me)
(forget-value! m1 me)
(forget-value! m2 me)
(process-new-value))
(define (me request)
(cond ((equal? request 'i-have-a-value) process-new-value)
((equal? request 'i-lost-my-value) process-forget-value)
(else (ErrorMsg "Unknown request -- MULTIPLIER" 'code))))
(connect m1 me)
(connect m2 me)
(connect product me)
me)
; ***********************************************************************
; (CONSTANT value var) -> var = value (constant)
(define (constant value var)
(define (me request)
(errormsg "Unknown request -- CONSTANT" 'code))
(connect var me)
(intern-set-value! var value me)
me)
; ***********************************************************************
; (EQUALIZER b1 b2) -> b1 = b2
(define (equalizer b1 b2)
(define (process-new-value)
(cond ((has-value? b1) (set-value! b2 (get-value b1) me))
((has-value? b2) (set-value! b1 (get-value b2) me))))
(define (process-forget-value)
(forget-value! b1 me)
(forget-value! b2 me)
(process-new-value))
(define (me request)
(cond ((equal? request 'i-have-a-value) process-new-value)
((equal? request 'i-lost-my-value) process-forget-value)
(else (ErrorMsg "Unknown request -- EQUALIZER" 'code))))
(connect b1 me)
(connect b2 me)
me)
; ***********************************************************************
; (SQUARE x xsquare) -> x^2 = xsquare
(define (square x xsquare)
(define (process-new-value)
(cond ((has-value? x)
(intern-set-value! xsquare (* (get-value x) (get-value x)) me))
((has-value? xsquare)
(cond ((< (get-value xsquare) 0)
(forget-value! currentvar currentinformant)
(ErrorMsg "Impossible to set a negative value to a square" 'user))
(else (intern-set-value! x (sqrt (get-value xsquare)) me))))))
(define (process-forget-value)
(forget-value! x me)
(forget-value! xsquare me)
(process-new-value))
(define (me request)
(cond ((equal? request 'i-have-a-value) process-new-value)
((equal? request 'i-lost-my-value) process-forget-value)
(else (ErrorMsg "Unknown request -- SQUARE" 'code))))
(connect x me)
(connect xsquare me)
me)
; ***********************************************************************
; (SINBOX a sina) -> sin(a) = sina
(define (sinbox a sina)
(define (process-new-value)
(cond ((has-value? a) (intern-set-value! sina (sin (get-value a)) me))
((has-value? sina)
(cond ((> (abs (get-value sina)) 1)
(forget-value! currentvar currentinformant)
(ErrorMsg "Value not in [-1..1]" 'user))
(else (intern-set-value! a (asin (get-value sina)) me))))))
(define (process-forget-value)
(forget-value! a me)
(forget-value! sina me)
(process-new-value))
(define (me request)
(cond ((equal? request 'i-have-a-value) process-new-value)
((equal? request 'i-lost-my-value) process-forget-value)
(else (ErrorMsg "Unknown request -- SIN" 'code))))
(connect a me)
(connect sina me)
me)
; ***********************************************************************
; (COSBOX a cosa) -> cos(a) = cosa
(define (cosbox a cosa)
(define (process-new-value)
(cond ((has-value? a) (intern-set-value! cosa (cos (get-value a)) me))
((has-value? cosa)
(cond ((> (abs (get-value cosa)) 1)
(forget-value! currentvar currentinformant)
(ErrorMsg "Value not in [-1..1]" 'user))
(else (intern-set-value! a (acos (get-value cosa)) me))))))
(define (process-forget-value)
(forget-value! a me)
(forget-value! cosa me)
(process-new-value))
(define (me request)
(cond ((equal? request 'i-have-a-value) process-new-value)
((equal? request 'i-lost-my-value) process-forget-value)
(else (ErrorMsg "Unknown request -- COS" 'code))))
(connect a me)
(connect cosa me)
me)
; ***********************************************************************
; (TANBOX a tana) -> tan(a) = tana
(define (tanbox a tana)
(define (process-new-value)
(cond ((has-value? a) (intern-set-value! tana (tan (get-value a)) me))
((has-value? tana)
(intern-set-value! a (atan (get-value tana)) me))))
(define (process-forget-value)
(forget-value! a me)
(forget-value! tana me)
(process-new-value))
(define (me request)
(cond ((equal? request 'i-have-a-value) process-new-value)
((equal? request 'i-lost-my-value) process-forget-value)
(else (ErrorMsg "Unknown request -- TAN" 'code))))
(connect a me)
(connect tana me)
me)
; ***********************************************************************
; (EXPBOX a expa) -> e^a = expa
(define (expbox a expa)
(define (process-new-value)
(cond ((has-value? a) (intern-set-value! expa (exp (get-value a)) me))
((has-value? expa)
(cond ((< (get-value expa) 0)
(forget-value! currentvar currentinformant)
(ErrorMsg "Impossible to set a value < 0 to a
exponential" 'user))
(else (intern-set-value! a (log (get-value expa)) me))))))
(define (process-forget-value)
(forget-value! a me)
(forget-value! expa me)
(process-new-value))
(define (me request)
(cond ((equal? request 'i-have-a-value) process-new-value)
((equal? request 'i-lost-my-value) process-forget-value)
(else (ErrorMsg "Unknown request -- EXP" 'code))))
(connect a me)
(connect expa me)
me)
; *******************************************************************
; Output to the TranscriptWindow of our own application
; probe redefinded from original version on 14.05.03
(define (probe name var)
(define (process-new-value)
(print-to-transcript (string-append "Probe:"
(symbol->string name)
"="
(number->string (get-value var)))))
(define (process-forget-value)
(print-to-transcript (string-append "Probe:"
(symbol->string name)
"= no more value")))
(define (me request)
(cond ((equal? request 'i-have-a-value) process-new-value)
((equal? request 'i-lost-my-value) process-forget-value)
(else (ErrorMsg "Unknown request -- PROBE" 'code))))
(connect var me)
me)
; redefined in errormsg.scm
;(define (ErrorMsg TheText)
; (error TheText))
; *******************************************************************
; ------------------------------------------------------------
; my-reset
; ------------------------------------------------------------
(define (my-reset)
(reset-proc 0 0))
; ------------------------------------------------------------
; end of my-reset
; ------------------------------------------------------------
;;--------------------------------------------------------------------------
;; end of arinet
;;--------------------------------------------------------------------------