#lang racket

;;; exo_16_14_10.rkt : solution de l'exercice page 375
;;; Examen L3-Info, Nice, 2006
;;; Livre "Premiers Cours de Programmation avec Scheme" (Ellipses Ed, 2010)

;;; <expr> ::= NUM | IDENT | BOOL | <special> | <applic>
;;; <special> ::= (if0 <expr> <expr> <expr>) | (function (IDENT ...) <expr>) | (with ((IDENT <expr) ...) expr)
;;; <applic> ::= (<expr> ...)

;;; Un langage purement fonctionnel en liaison statique avec un syntaxe tres reduite.
;;; Les seules primitives arithmetiques sont + et -, avec un (ifO p q r).

;;; Un environnement est une simple A-liste geree en pile. Pas de tables de hash-code.

(define $global-env
  `((+ (*prim* ,+)) (- (*prim* ,-))))


; l'evaluateur en liaison statique

(define (main-static)
  (define ($eval expr env)
    (cond ((or (number? expr) (boolean? expr)) expr)
          ((symbol? expr) (let ((try (assoc expr env))) 
                            (if try (cadr try) (error "Unbound identifier" expr))))
          ((equal? 'function (car expr)) (list '*closure* (cadr expr) (caddr expr) env))              ; fermetures !
          ((equal? 'if0 (car expr)) 
           (if (= 0 ($eval (cadr expr) env)) ($eval (caddr expr) env) ($eval (cadddr expr) env)))
          ((equal? 'with (car expr))
           ($eval `((function ,(map car (cadr expr)) ,(caddr expr)) ,@(map cadr (cadr expr))) env))   ; macro-expansion ! 
          (else ($apply ($eval (car expr) env) 
                        (map (lambda (x) ($eval x env)) (cdr expr))))))
  (define ($apply proc Largs)
    (if (and (pair? proc) (equal? (car proc) '*prim*))
        ((cadr proc) (car Largs) (cadr Largs))
        ($eval (caddr proc) (append (map list (cadr proc) Largs) (cadddr proc)))))
  (define (toplevel)
    (printf "? ")
    (let ((expr (read)))
      (when (not (equal? expr 'quit))
        (printf "= ~a~n" ($eval expr $global-env))
        (toplevel))))
  (let ((L '((with ((x 1) (y 2)) (+ x y))
             (with ((x 1) (y 2)) (if0 x #t #f))
             (with ((x 1) (y 2)) (+ 1 (if0 x (+ y 1) (- y 1))))
             (with ((x 1) (y 2)) +)
             (with ((x 1) (y 2)) (function () (+ x 1)))
             (with ((x 1) (y 2)) (function (f) (f x)))
             (with ((a 1)) (with ((f (function (x) (+ x a)))) (with ((a 1000)) (f a))))
             (with ((x 1) (y 2)) ((function (x) (if0 x 0 (+ x 1))) (+ y 1)))
             (with ((x 1) (y 2)) (+ (with ((x (+ y 1))) (+ x 1)) x)))))
    (for-each (lambda (x) (printf "? ~a~n= ~a~n" x ($eval x $global-env))) L)   ; tests automatiques en prelude
    (toplevel)))

(printf "LIAISON STATIQUE :\n")
(main-static)

; l'evaluateur en liaison dynamique

(define (main-dynamic)
  (define ($eval expr env)
    (cond ((or (number? expr) (boolean? expr)) expr)
          ((symbol? expr) (let ((try (assoc expr env))) 
                            (if try (cadr try) (error "Unbound identifier" expr))))
          ((equal? 'function (car expr)) (list '*function* (cadr expr) (caddr expr)))  ; plus de env !
          ((equal? 'if0 (car expr)) 
           (if (= 0 ($eval (cadr expr) env)) ($eval (caddr expr) env) ($eval (cadddr expr) env)))
          ((equal? 'with (car expr))
           ($eval `((function ,(map car (cadr expr)) ,(caddr expr)) ,@(map cadr (cadr expr))) env))   ; macro-expansion ! 
          (else ($apply ($eval (car expr) env) 
                        (map (lambda (x) ($eval x env)) (cdr expr))
                        env))))
  (define ($apply proc Largs env)   ; env dynamique !!
    (if (and (pair? proc) (equal? (car proc) '*prim*))
        ((cadr proc) (car Largs) (cadr Largs))
        ($eval (caddr proc) (append (map list (cadr proc) Largs) env)))) ; on etend env et non l'env. de compilation !
  (define (toplevel)
    (printf "? ")
    (let ((expr (read)))
      (when (not (equal? expr 'quit))
        (printf "= ~a~n" ($eval expr $global-env))
        (toplevel))))
  (let ((L '((with ((x 1) (y 2)) (+ x y))
             (with ((x 1) (y 2)) (if0 x #t #f))
             (with ((x 1) (y 2)) (+ 1 (if0 x (+ y 1) (- y 1))))
             (with ((x 1) (y 2)) +)
             (with ((x 1) (y 2)) (function () (+ x 1)))
             (with ((x 1) (y 2)) (function (f) (f x)))
             (with ((a 1)) (with ((f (function (x) (+ x a)))) (with ((a 1000)) (f a))))
             (with ((x 1) (y 2)) ((function (x) (if0 x 0 (+ x 1))) (+ y 1)))
             (with ((x 1) (y 2)) (+ (with ((x (+ y 1))) (+ x 1)) x)))))
    (for-each (lambda (x) (printf "? ~a~n= ~a~n" x ($eval x $global-env))) L)   ; tests automatiques en prelude
    (toplevel)))

(printf "LIAISON DYNAMIQUE :\n")
(main-dynamic)