#lang racket
;;; exam-pf2-jan-2017.rkt

(define-syntax while
  (syntax-rules ()
    ((while test e1 e2 ...) (do () ((not test) (void)) e1 e2 ...))))

(define-syntax show
  (syntax-rules ()
    ((show e) (begin (printf "? ~s\n" 'e) (printf "--> ~s\n" e)))))
;;;------------------------------------------------------------------

"1 - Une petite fonction dans divers styles"

(define (zip L1 L2)
  (if (null? L1)
      '()
      (cons (list (car L1) (car L2)) (zip (rest L1) (rest L2)))))

(show (zip '(a b c) '(1 2 3)))

(define (zip-it L1 L2)
  (define (iter L1 L2 acc)
    (if (null? L1)
        (reverse acc)
        (iter (cdr L1) (cdr L2) (cons (list (car L1) (car L2)) acc))))
  (iter L1 L2 '()))

(show (zip-it '(a b c) '(1 2 3)))

(define (zip-os L1 L2)
  (map list L1 L2))

(show (zip-os '(a b c) '(1 2 3)))

(define (zip-imp L1 L2)
  (let ((acc '()))
    (while (not (null? L1))
      (set! acc (cons (list (car L1) (car L2)) acc))
      (set! L1 (cdr L1))
      (set! L2 (cdr L2)))
    (reverse acc)))

(show (zip-imp '(a b c) '(1 2 3)))

(define (gen-zip L1 L2)
  (lambda ()
    (if (null? L1)
        '*echec*
        (let ((x (car L1)) (y (car L2)))
          (set! L1 (cdr L1))
          (set! L2 (cdr L2))
          (list x y)))))

(define gus (gen-zip '(a b c) '(1 2 3)))
(show (gus))
(show (gus))
(show (gus))
(show (gus))
(newline)

"2 - Une nouvelle structure de boucle"

; a) 
; - parce que si n = 0, une fonction aurait deja evalue au moins une fois ses arguments e1, e2,...
; - ou parce qu'une fonction evaluerait d'abord ses arguments e1,e2,... et dont elle continuerait
;   par evaluer les *valeurs* des expressions et non les expressions elles-memes !

; b) 

(define-syntax repeat
  (syntax-rules ()
    ((repeat n e1 e2 ...) (let ()
                            (define (iter i)    ; par exemple, ou avec une boucle for, etc
                              (if (<= i 0) (void) (begin e1 e2 ... (iter (- i 1)))))
                            (iter n)))))

(define x 0)
(show (begin (repeat 5 (set! x (+ x 1)) (printf "~a " x)) (newline)))
(show x)
(newline)

"3 - Un petit transformateur syntaxique"

(define (and->if expr)
  (cond ((not (pair? expr)) expr)
        ((equal? (car expr) 'and)        ; and binaire !
         (list 'if (and->if (cadr expr)) (and->if (caddr expr)) #f))
        (else (map and->if expr))))

(show (and->if '(and p q)))
(show (and->if '(if (and (> x 0) (> y 0)) (+ x 1) (- x 1))))
(show (and->if '(or (if (and (> x 0) (and (> y 0) (= x y)))
                  (> x z)
                  (and (> x z) (= z 2))))))
(show (and->if '((if (and (> x 0) (> y 0)) + -) 2 3)))
(show (and->if '(+ 1 2)))
(newline)

"4 - Une classe de listes comme en Python"

(define plist%
  (class object%
    ; pas de (init-field ...) puisque le constructeur n'a pas de parametre !!!
    ; les CHAMPS PRIVES ne sont PAS initialisables ou modifiables par l'utilisateur.
    (define v (make-vector 3 '?))    ; capacite initiale de 3
    (define k 0)                     ; indice de la premiere case libre
    (define/public (len)
      k)
    (define/public (get i)           ; acces a l'element numero i
      (if (and (>= i 0) (< i k))
          (vector-ref v i)
          (error "plist% : invalid index in get :" i)))
    (define/public (append x)
      (define n (vector-length v))
      (when (>= k n)
        (set! v (build-vector (* 2 n)        
                              (lambda (i)
                                (if (< i k) (vector-ref v i) '?)))))
      (vector-set! v k x)
      (set! k (+ k 1)))
    (define/public (pop i)
      (define x (vector-ref v i))
      (for ([j (in-range (+ i 1) k)])
           (vector-set! v (- j 1) (vector-ref v j)))
      (vector-set! v (- k 1) '?)
      (set! k (- k 1))
      x)
    (define/public (dump)       ; "to dump" <==> "larguer" : "She dumped her boy-friend !" 
      (printf "DUMP: ")
      (for ([i (in-range 0 (vector-length v))])
           (printf "~a " (vector-ref v i)))
      (printf "\n"))
    (super-new)))

(define L (new plist%))         ; Look 'Ma, I've got Python lists !
(show L)
(show (send L append 'a))
(show (send L append 'b))
(show (send L append 'c))
(show (send L dump))
(show (send L append 'd))
(show (send L len))
(show (send L dump))
(show (send L pop 2))
(show (send L dump))
(show (send L get 2))

(require racket/exn)
(printf "\n### Trying (send L get 3) :\n")
(with-handlers ([exn:fail? (lambda (exn) (printf (exn->string exn)))])   ; try... except...
  (send L get 3))

(newline)
(show (send L pop 0))
(show (send L dump))
'(The time has come - the walrus said - to talk of many things...)