system.scm

;;Constraint-system
;;----------------
;;Inspiração SICP - 3.3.5 Propagation of Constraints
;;Modificado, mais operacoes e nova systax.

(use-modules (ice-9 match))

(define degrees #t)
(define pi 3.141592654)
(define precision 1e-7)

(define (adder a1 a2 sum)
  (define (process-new-value)
    (cond ((and (has-value? a1) (has-value? a2))
           (set-value! sum
                       (+ (get-value a1) (get-value a2))
                       me))
          ((and (has-value? a1) (has-value? sum))
           (set-value! a2
                       (- (get-value sum) (get-value a1))
                       me))
          ((and (has-value? a2) (has-value? sum))
           (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 ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- ADDER" request))))
  (connect a1 me)
  (connect a2 me)
  (connect sum me)
  me)

(define (subtractor s1 s2 sub)
  (define (process-new-value)
    (cond ((and (has-value? s1) (has-value? s2))
           (set-value! sub
                       (- (get-value s1) (get-value s2))
                       me))
          ((and (has-value? s1) (has-value? sub))
           (set-value! s2
                       (- (get-value s1) (get-value sub))
                       me))
          ((and (has-value? s2) (has-value? sub))
           (set-value! s1
                       (+ (get-value sub) (get-value s2))
                       me))))
  (define (process-forget-value)
    (forget-value! sub me)
    (forget-value! s1  me)
    (forget-value! s2  me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- SUBTRACTOR " request))))
  (connect s1  me)
  (connect s2  me)
  (connect sub me)
  me)

(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)))
           (set-value! product 0 me))
          ((and (has-value? m1) (has-value? m2))
           (set-value! product
                       (* (get-value m1) (get-value m2))
                       me))
          ((and (has-value? product) (has-value? m1))
           (set-value! m2
                       (/ (get-value product) (get-value m1))
                       me))
          ((and (has-value? product) (has-value? m2))
           (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 ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- MULTIPLIER" request))))
  (connect m1 me)
  (connect m2 me)
  (connect product me)
  me)

(define (divider d1 d2 quotient)
  (define (process-new-value)
    (cond ((and (has-value? d1) (has-value? d2))
           (cond ((not (= (get-value d2) 0))
                  (set-value! quotient
                              (/ (get-value d1) (get-value d2))
                              me))))
          ((and (has-value? d1) (has-value? quotient))
           (cond ((not (= (get-value quotient) 0))
                  (set-value! d2
                              (/ (get-value d1) (get-value quotient))
                              me))))
          ((and (has-value? d2) (has-value? quotient))
           (set-value! d1
                       (* (get-value d2) (get-value quotient))
                       me))))
  (define (process-forget-value)
    (forget-value! quotient me)
    (forget-value! d1       me)
    (forget-value! d2       me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- DIVIDER " request))))
  (connect quotient me)
  (connect d1       me)
  (connect d2       me)
  me)

(define (degrees-to-radians ang)
  (if degrees
      (/ (* ang pi) 180)
      ang))

(define (radians-to-degrees ang)
  (if degrees
      (/ (* ang 180) pi)
      ang))

(define (sine ang value-sin)
  (define (process-new-value)
    (cond ((has-value? ang)
           (let ((calc (sin (degrees-to-radians (get-value ang)))))
             (cond ((and (>= calc -1) (<= calc 1))
                    (set-value! value-sin
                                calc
                                me)))))
          ((and (has-value? value-sin) (<= (get-value value-sin) 1)
                (>= (get-value value-sin) -1))           
           (set-value! ang
                       (radians-to-degrees (asin (get-value value-sin)))
                       me))))
  (define (process-forget-value)
    (forget-value! value-sin me)
    (forget-value! ang       me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- SIN " request))))
  (connect value-sin me)
  (connect ang me)
  me)

(define (cosine ang value-cos)
  (define (process-new-value)
    (cond ((has-value? ang)
           (let ((calc (cos (degrees-to-radians (get-value ang)))))
             (cond ((and (<= calc 1) (>= calc -1))
                    (set-value! value-cos
                                calc
                                me)))))
          ((and (has-value? value-cos) (<= (get-value value-cos) 1)
                (>= (get-value value-cos) -1))
           (set-value! ang
                       (radians-to-degrees (acos (get-value value-cos)))
                       me))))
  (define (process-forget-value)
    (forget-value! value-cos me)
    (forget-value! ang       me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- COS " request))))
  (connect value-cos me)
  (connect ang       me)
  me)

(define (tangent ang value-tan)
  (define (process-new-value)
    (cond ((has-value? ang)
           (set-value! value-tan
                       (tan (degrees-to-radians (get-value ang)))
                       me))
          ((has-value? value-tan)
           (set-value! ang
                       (radians-to-degrees (atan (get-value value-tan)))
                       me))))
  (define (process-forget-value)
    (forget-value! value-tan me)
    (forget-value! ang       me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- TAN " request))))
  (connect value-tan me)
  (connect ang       me)
  me)

(define (square-root num root)
  (define (process-new-value)
    (cond ((and (has-value? num) (>= (get-value num) 0))
           (set-value! root
                       (sqrt (get-value num))
                       me))
          ((and (has-value? root) (real? (get-value root)))
           (set-value! num
                       (expt root 2)
                       me))))
  (define (process-forget-value)
    (forget-value! root me)
    (forget-value! num  me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- SQUARE-ROOT " request))))
  (connect root me)
  (connect num  me)
  me)

(define (square num value-sqr)
  (define (process-new-value)
    (cond ((has-value? num)
           (set-value! value-sqr
                       (expt (get-value num) 2)
                       me))
          ((and (has-value? value-sqr) (>= (get-value value-sqr) 0))
           (set-value! num
                       (sqrt (get-value value-sqr))
                       me))))
  (define (process-forget-value)
    (forget-value! value-sqr me)
    (forget-value! num me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- SQUARE " request))))
  (connect value-sqr me)
  (connect num me)
  me)

(define (equal num1 num2)
  (define (process-new-value)
    (cond ((has-value? num1)
           (set-value! num2
                       (get-value num1)
                       me))
          ((has-value? num2)
           (set-value! num1
                       (get-value num2)
                       me))))
  (define (process-forget-value)
    (forget-value! num2 me)
    (forget-value! num1 me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- EQUAL " request))))
  (connect num1 me)
  (connect num2 me)
  me)

(define (equal-less num1 num2)
  (define (process-new-value)
    (cond ((has-value? num1)
           (set-max! num1 (get-value num1))
           (set-min! num2 (get-value num1)) )
          ((has-value? num2)
           (set-max! num1 (get-value num2))
           (set-min! num2 (get-value num2))) ))
  (define (process-forget-value)
    (forget-value! num1 me)
    (forget-value! num2 me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unkwown request -- EQUAL LESS " request))))
  (connect num1 me)
  (connect num2 me)
  me)

(define (equal-more num1 num2)
  (define (process-new-value)
    (cond ((has-value? num1)
           (set-min! num1 (get-value num1))
           (set-max! num2 (get-value num1)) )
          ((has-value? num2)
           (set-min! num1 (get-value num2))
           (set-max! num2 (get-value num2))) ))
  (define (process-forget-value)
    (forget-value! num1 me)
    (forget-value! num2 me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unkwown request -- EQUAL LESS " request))))
  (connect num1 me)
  (connect num2 me)
  me)


(define (constant value connector)
  (define (me request)
    (error "Unknown request -- CONSTANT" request))
  (connect connector me)
  (set-value! connector value me)
  me)

(define (inform-about-value constraint)
  (constraint 'I-have-a-value))
(define (inform-about-no-value constraint)
  (constraint 'I-lost-my-value))

(define (probe name connector)
  (define (print-probe value)
    (display "Probe: ")
    (display name)
    (display " = ")
    (display value)
    (display "\n"))
  (define (process-new-value)
    (print-probe (get-value connector)))
  (define (process-forget-value)
    (print-probe "?"))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (process-new-value))
          ((eq? request 'I-lost-my-value)
           (process-forget-value))
          (else
           (error "Unknown request -- PROBE" request))))
  (connect connector me)
  me)

(define (make-connector)
  (let ((value #f) (informant #f) (constraints '()) (min #f) (max #f) (flag #f))
    (define (set-my-value newval setter)
      (cond ((not (has-value? me))
             (cond ((and (not min) (not max))
                    (set! flag #t)
                    (set! value newval))
                   ((and (not min) max)
                    (when (< newval max)
                        (begin
                          (set! flag #t)
                          (set! value newval)) ))
                   ((and min (not max))
                    (when (> newval min)
                        (begin
                          (set! flag #t)
                          (set! value newval)) ))
                   ((and min max)
                    (when (and (> newval min) (< newval max))
                        (begin
                          (set! flag #t)
                          (set! value newval)) )))
             (if flag
                 (begin
                   (set! flag #f)
                   (set! informant setter)
                   (for-each-except setter
                                    inform-about-value
                                    constraints))
                 'ignored))
            ((has-value? me)
             (cond ((and (not min) (not max) (not (< (abs (- value newval)) precision)))
                    (set! flag #t))
                   ((and (not min) max (> newval max))
                    (set! flag #t))
                   ((and min (not max) (< newval min))
                    (set! flag #t))
                   ((and min max (> newval max) (< newval min))
                    (set! flag #t)))
             (if flag
                 (begin
                   (set! flag #f)
                   (error "Contradiction" (list value newval)))
                 'ignored))
            (else 'ignored)))
    (define (set-my-min minval)
      (set! min minval))
    (define (set-my-max maxval)
      (set! max maxval))
    (define (forget-my-value retractor)
      (if (eq? retractor informant)
          (begin (set! informant #f)
                 (set! min #f)
                 (set! max #f)
                 (for-each-except retractor
                                  inform-about-no-value
                                  constraints))
          'ignored))
    (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))
      'done)
    (define (me request)
      (cond ((eq? request 'has-value?)
             (if informant #t #f))
            ((eq? request 'value) value)
            ((eq? request 'set-value!) set-my-value)
            ((eq? request 'forget) forget-my-value)
            ((eq? request 'connect) connect)
            ((eq? request 'set-min!) set-my-min)
            ((eq? request 'set-max!) set-my-max)
            (else (error "Unknown operation -- CONNECTOR"
                         request))))
    me))

(define (for-each-except exception procedure list)
  (let loop ((items list))
    (cond ((null? items) 'done)
          ((eq? (car items) exception) (loop (cdr items)))
          (else (procedure (car items))
                (loop (cdr items)))))
  )

(define (has-value? connector)
  (connector 'has-value?))
(define (get-value connector)
  (connector 'value))
(define (set-value! connector new-value informant)
  ((connector 'set-value!) new-value informant))
(define (forget-value! connector retractor)
  ((connector 'forget) retractor))
(define (connect connector new-constraint)
  ((connector 'connect) new-constraint))
(define (set-min! connector minval)
  ((connector 'set-min!) minval))
(define (set-max! connector maxval)
  ((connector 'set-max!) maxval))