#lang racket

;;; chap12.rkt - Les sources du chapitre 12 (la mutation)
;;; Livre PCPS : "Premiers Cours de Programmation avec Scheme"
;;; Langage determine par le source

(provide (all-defined-out))   ; pour les exercices...

;;; Le paragraphe 'LA MUTATION EST INTERNE A UN MODULE' est important (pages 244-245)

(require "show.rkt")     ; le bon vieux show pour les tests...

(define (reverse-imperatif L)    ; pur imperatif !
  (let ((res '()))
    (do ()        ; pas de variables de boucle dans ce do
      ((null? L) res)
      (set! res (cons (car L) res))
      (set! L (cdr L)))))

;(show (reverse-imperatif '(a b (c d) e)))

(define-syntax $do           ; ligne 61
  (syntax-rules ()
    (($do ((x i s) ...)      ; les variables de boucle
          (test expr ...)    ; le cas d'arret
          e ...)             ; le corps de boucle
     (let ()
       (define (iter x ...)
         (if test
             (begin expr ...)
             (begin e ... (iter s ...))))
       (iter i ...)))))

;(printf "Exemple de $do (fonctionnel) : 10! = ~a\n"
;        ($do ((i 1 (+ i 1)) (res 1 (* res i)))
;             ((> i 10) res)))

;(printf "Exemple de $do (imperatif)   : 10! = ~a\n"
;        (let ((res 1))
;          ($do ((i 1 (+ i 1)))
;             ((> i 10) res)
;             (set! res (* res i)))))

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

;(printf "Exemple de while : 10! = ~a\n"
;        (let ((n 10) (res 1))
;          (while (> n 0)
;                 (set! res  (* n res))
;                 (set! n (- n 1)))
;          res))

; Attention, je tue le 'for' primitif de Racket que je n'utilise pas dans le livre...
; Le cas echeant, nommez-le 'For' si vous voulez disposer des deux !

(define-syntax for             ; ligne 88
  (syntax-rules (from to by)
    ((for i from a to b by c e1 e2 ...) (let* ((va a) (vb b) (vc c))
                                          (when (or (> va vb) (< vc 0))
                                            (error 'for "Bornes de boucle invalides !"))
                                          (do ((i va (+ i vc)))
                                            ((> i vb) (void))
                                            e1 e2 ...)))
    ((for i from a to b e1 e2 ...) (for i from a to b by 1 e1 e2 ...))))

;(printf "Exemple de for   : 10! = ~a\n"
;        (let ((res 1))
;          (for i from 1 to 10
;            (set! res (* res i)))
;          res))

(define-syntax echanger!       ; ligne 129
  (syntax-rules ()
    ((echanger! x y) (let ((tmp x))
                       (set! x y)
                       (set! y tmp)))))

;(define a 1)
;(define b 2)
;(printf "Avant l'echange : a = ~a et b = ~a\n" a b)
;(echanger! a b)
;(printf "Apres l'echange : a = ~a et b = ~a\n" a b)

"LES GENERATEURS (page 249)"

(define (make-gen-fac)              ; ligne 158
  (let ((n 0) (f 1) (old-f '?))
    (lambda ()
      (set! old-f f)
      (set! n (+ n 1))
      (set! f (* f n))
      old-f)))

;(printf "Les premieres factorielles : ")
;(let ((gauss (make-gen-fac)))
;  (do ((i 0 (+ i 1)))
;    ((> i 10) (printf "\n"))
;    (printf "~a " (gauss))))

(define (make-gen-list L)             ; ligne 177
  (lambda ()
    (if (null? L)
        '*echec*
        (let ((x (car L)))
          (set! L (cdr L))
          x))))

;(printf "Generation des elements de (a b c d) : ")
;(let ((gen (make-gen-list '(a b c d))))
;  (do ((i 0 (+ i 1)))
;    ((> i 6) (printf "...\n"))
;    (printf "~a " (gen))))

"LES FONCTIONS A MEMOIRE (page251)"

(define (make-memo-fib)             ; ligne 184
  (let ((AL '()))
    (define (calc n)
      (if (< n 2)
          n
          (let ((essai (assoc n AL)))
            (if essai
                (cdr essai)
                (let ((f (+ (calc (- n 1)) (calc (- n 2)))))
                  (set! AL (cons (cons n f) AL))    ; memoire a court terme
                  f)))))
    calc))

;(define fibo (make-memo-fib))
;(printf "Calcul O(n) de (fibo 2000) : ")
;(time (fibo 2000))
;(printf "Le meme calcul : ")
;(time (fibo 2000))   ; <-- immediat car en memoire

;;; Les lignes 196--204 sont fausses, voir la feuille d'errata !

(define-syntax memo-lambda           ; ligne 205
  (syntax-rules ()
    ((memo-lambda (x) e ...) (let ((AL '()))
                               (lambda (x)
                                 (let ((essai (assoc x AL)))
                                   (if essai
                                       (cdr essai)
                                       (let ((v (begin e ...)))
                                         (set! AL (cons (cons x v) AL))
                                         v))))))))

(define fib (memo-lambda (n)
                         (if (< n 2)
                             n 
                             (+ (fib (- n 1)) (fib (- n 2))))))

;(printf "Calcul O(n) de (fib 2000) : ")
;(time (fib 2000))
;(printf "Le meme calcul : ")
;(time (fib 2000))   ; <-- immediat car en memoire
;(printf "Calcul O(n) de (fib 500) : ")
;(time (fib 500))

"LES ACTEURS ET LES ENVOIS DE MESSAGES (page 253)"

(define (new-gen-fac)             ; ligne 237
  (let ((n 0) (f 1))
    (define (this sel . Largs)
      (case sel
        ((reset) (if (null? Largs)
                     (begin (set! n 0) (set! f 1))
                     (begin (set! n (car Largs)) (set! f (cadr Largs)))))
        ((mem) (list n f))
        ((next) (let ((old-f f))
                  (set! n (+ n 1))
                  (set! f (* f n))
                  old-f))
        (else (error 'new-gen-fac "Selecteur inconnu ~a" sel))))
    this))

;(define FAC (new-gen-fac))
;(printf "Les premieres factorielles en style acteur : ")
;(do ((i 0 (+ i 1)))
;  ((> i 6) (printf " (mem = ~a)\n" (FAC 'mem)))
;  (printf "~a " (FAC 'next)))

"LE GRAPHISME IMPERATIF (page 256)"

#|
(require graphics/graphics)            ; ligne 299

(open-graphics)
(define VIEW (open-viewport "Essai graphics" 300 100))
(define tr-segment (draw-line VIEW))
(define tr-pixel (draw-pixel VIEW))
(define A (make-posn 150 10))
(define B (make-posn 10 90))
(define C (make-posn 290 90))

(define M-INIT (make-posn (random 300) (random 100)))

(define (jeu-du-chaos)
  (define (moyenne x y)
    (/ (+ x y) 2))
  (define (milieu A B)
    (make-posn (moyenne (posn-x A) (posn-x B))
               (moyenne (posn-y A) (posn-y B))))
  (define (iter nb-fois M)   ; M est le dernier point courant affiche
    (if (= nb-fois 0)
      (void)
      (let* ((S (case (random 3) ((0) A) ((1) B) ((2) C)))
             (Msuiv (milieu M S)))
        (tr-pixel Msuiv "blue")
        (iter (- nb-fois 1) Msuiv))))
  (tr-pixel M-INIT "blue")
  (iter 3000 M-INIT))

(printf "Voir le jeu du chaos !\n")
(jeu-du-chaos)
|#

"LE GRAPHISME DE LA TORTUE (page 258)"

;(require "tortue.rkt")   ; qui exporte (new-tortue), la variable TORTUES et la macro repeat

;(define lea (new-tortue))

(define (von-koch n c t)   ; avec la tortue t
  (if (= n 0)
      (t 'av c)
      (begin (von-koch (- n 1) (/ c 3) t)
             (t 'ga 60)
             (von-koch (- n 1) (/ c 3) t)
             (t 'dr 120)
             (von-koch (- n 1) (/ c 3) t)
             (t 'ga 60)
             (von-koch (- n 1) (/ c 3) t))))

;(printf "Voir la courbe de Von Koch !\n")
;(lea 'init '(-200 0) 90)   ; position et cap initiaux
;(von-koch 3 400 lea)

"LA MUTATION DES STRUCTURES (page 263)"

(require 2htdp/image 2htdp/universe)

(define (monde-mutable)    
  (let* ((BALLE (bitmap "ballon.png"))  ; image carree
         (R (/ (image-width BALLE) 2.0))
         (FOND (rectangle (* 2 R) 400 'solid "yellow")) 
         (y 100.0)        ; ordonnee initiale de la balle
         (dy 0.0)         ; vitesse initiale de la balle
         (G 1.0)          ; acceleration gravitationnelle
         (F 0.9))         ; coeff. de frottement au sol
    (define (=? a b)
      (< (abs (- a b)) 0.1))
    (define (suivant m)     ; le Monde est ignore
      (set! y (+ y dy))
      (when (> y (- 400 R))              ; rebond
        (set! y (- 400 R))
        (set! dy (* F (- dy))))          ; avec frottement !
      (set! dy (+ dy G)))
    (define (dessiner m)    ; le Monde est ignore
      (place-image BALLE R y FOND))
    (big-bang '?            ; le Monde initial est ignore
              (on-tick suivant)
              (on-draw dessiner)
              (stop-when (lambda (m) (and (=? y (- 400 R)) (=? dy 0)))))))

;(printf "Voir la balle qui rebondit !\n")
;(monde-mutable)

"LA MUTATION DES VECTEURS (page 265)"

(define (vect-echanger! v i j)   ; echanger! est deja dans ce fichier !!
  (let ((tmp (vector-ref v i)))
    (vector-set! v i (vector-ref v j))
    (vector-set! v j tmp)))

;(define v (vector 5 1 7 4 2))
;(printf "Avant l'echange des elements numeros 1 et 3 : v = ~a\n" v)
;(vect-echanger! v 1 3)
;(printf "Apres l'echange : v = ~a\n" v)
 
(define (build-matrix p q f)         ; ligne 468
  (build-vector p (lambda (i)
                    (build-vector q (lambda (j) (f i j))))))

(define (matrix-ref M i j)
  (vector-ref (vector-ref M i) j))

(define (matrix-set! M i j x)
  (vector-set! (vector-ref M i) j x))

(define (matrix-format M)   ; si M est rectangulaire...
  (list (vector-length M) (vector-length (vector-ref M 0))))

;(define MA (build-matrix 3 2 +))
;(define MB #(#(10 20)
;             #(0  -2)
;             #(1   5)))
;
;(show MA)
;(show MB)
;(show (matrix-format MA))

"LA MUTATION DES DOUBLETS (page 270)"

(require racket/mpair)     ; pour les doublets mutables

(define (subst! x y L)     ; ligne 520
  (cond ((null? L) (void))
        ((equal? (mcar L) x) (set-mcar! L y))
        (else (subst! x y (mcdr L)))))

;(define L (mlist 'a 'b 'c 'd))
;(show L)
;(subst! 'c 2 L)
;(printf "Apres (subst! 'c 2 L) :\n")
;(show L)

(define-syntax suppression!              ; ligne 528
  (syntax-rules ()
    ((suppression! x L) (let ((vx x))    ; pour ne pas recalculer x
                          (cond ((null? L) (void))
                                ((equal? (mcar L) vx) 
                                 (set! L (mcdr L)))
                                (else (suppr! vx L)))))))

(define (suppr! x L)               ; L non vide, x n'est pas le car
  (cond ((null? (mcdr L)) (void))
        ((equal? (mcar (mcdr L)) x) (set-mcdr! L (mcdr (mcdr L))))
        (else (suppr! x (mcdr L)))))

;(suppression! 'a L)
;(printf "Apres (suppression! 'a L) :\n")
;(show L)
;(suppression! 2 L)
;(printf "Apres (suppression! 2 L) :\n")
;(show L)

;(define L1 (mlist 'a 'b 'c))       ; ligne 542
;(define L2 (mlist 1 2))
;(define L3 (mappend! L1 L2))
;(show L3)
;(set! L1 (mlist 'a 'b 'c))
;(mappend! L1 L1)
;(printf "Je rends la liste {a b c} circulaire :\n")
;(show L1)

(define (circulaire? L)       ; L est mutable, ligne 559
  (define (iter L deja-vus)   ; deja-vus est une liste de références
    (cond ((null? L) #f)
          ((memq L deja-vus) #t)                  ; memq utilise eq?
          (else (iter (mcdr L) (cons L deja-vus)))))
  (iter L '()))

;(show (circulaire? L1))

"LES TABLES DE HASH-CODE (page 275)"
;;; Excellente structure de donnees, beaucoup plus rapides que les A-listes ! Quasiment du O(1)...

;(define ht (make-hash))
;(hash-set! ht 'prix 2500)
;(hash-set! ht 'options '(diesel turbo clim))
;(show ht)
;(show (hash-ref ht 'prix))