#lang racket

;; pomocnicza funkcja dla list tagowanych o określonej długości

(define (tagged-tuple? tag len p)
  (and (list? p)
       (= (length p) len)
       (eq? (car p) tag)))

(define (tagged-list? tag p)
  (and (pair? p)
       (eq? (car p) tag)
       (list? (cdr p))))

;;
;; WHILE
;;

; memory

(define empty-mem
  null)

(define (set-mem x v m)
  (cond [(null? m)
         (list (cons x v))]
        [(eq? x (caar m))
         (cons (cons x v) (cdr m))]
        [else
         (cons (car m) (set-mem x v (cdr m)))]))

(define (get-mem x m)
  (cond [(null? m) 0]
        [(eq? x (caar m)) (cdar m)]
        [else (get-mem x (cdr m))]))

; arith and bool expressions: syntax and semantics

(define (const? t)
  (number? t))

(define (true? t)
  (eq? t 'true))

(define (false? t)
  (eq? t 'false))

(define (op? t)
  (and (list? t)
       (member (car t) '(+ - * / = > >= < <= not and or mod rand))))

(define (op-op e)
  (car e))

(define (op-args e)
  (cdr e))

(define (op->proc op)
  (cond [(eq? op '+) +]
        [(eq? op '*) *]
        [(eq? op '-) -]
        [(eq? op '/) /]
        [(eq? op '=) =]
        [(eq? op '>) >]
        [(eq? op '>=) >=]
        [(eq? op '<)  <]
        [(eq? op '<=) <=]
        [(eq? op 'not) not]
        [(eq? op 'and) (lambda x (andmap identity x))]
        [(eq? op 'or) (lambda x (ormap identity x))]
        [(eq? op 'mod) modulo]
        [(eq? op 'rand) (lambda (max) (min max 4))])) ; chosen by fair dice roll.
; guaranteed to be random.

(define (var? t)
  (symbol? t))

(define (eval-arith e m)
  (cond [(true? e) true]
        [(false? e) false]
        [(var? e) (get-mem e m)]
        [(op? e)
         (apply
          (op->proc (op-op e))
          (map (lambda (x) (eval-arith x m))
               (op-args e)))]
        [(const? e) e]))

;; syntax of commands

(define (assign? t)
  (and (list? t)
       (= (length t) 3)
       (eq? (second t) ':=)))

(define (assign-var e)
  (first e))

(define (assign-expr e)
  (third e))

(define (if? t)
  (tagged-tuple? 'if 4 t))

(define (if-cond e)
  (second e))

(define (if-then e)
  (third e))

(define (if-else e)
  (fourth e))

(define (while? t)
  (tagged-tuple? 'while 3 t))

(define (while-cond t)
  (second t))

(define (while-expr t)
  (third t))

(define (block? t)
  (list? t))

;; state

(define (res v s)
  (cons v s))

(define (res-val r)
  (car r))

(define (res-state r)
  (cdr r))

;; psedo-random generator

(define initial-seed
  123456789)

(define (rand max)
  (lambda (i)
    (let ([v (modulo (+ (* 1103515245 i) 12345) (expt 2 32))])
      (res (modulo v max) v))))

;; WHILE interpreter

(define (old-eval e m)
  (cond [(assign? e)
         (set-mem
          (assign-var e)
          (eval-arith (assign-expr e) m)
          m)]
        [(if? e)
         (if (eval-arith (if-cond e) m)
             (old-eval (if-then e) m)
             (old-eval (if-else e) m))]
        [(while? e)
         (if (eval-arith (while-cond e) m)
             (old-eval e (old-eval (while-expr e) m))
             m)]
        [(block? e)
         (if (null? e)
             m
             (old-eval (cdr e) (old-eval (car e) m)))]))


(define (eval e m seed)

  (define (rand? e)
    (tagged-list? 'rand e))
  (define (rand-arg e)
    (second e))

  (define (eval-arith-seed e m seed) ;zwraca res, gdzie res-val to wartość, a res-state to ziarno

    (define (op-helper xs seed) ;zwraca res: listę obliczonych argumentów i ziarno z obliczenia ostatniego argumentu
      (if (null? xs)
          (res null seed)
          (let* ((x (eval-arith-seed (car xs) m seed))
                 (y (op-helper (cdr xs) (res-state x))))
            (res (cons (res-val x)
                       (res-val y))
                 (res-state y)))))

    (cond [(rand? e)
           (let ((x (eval-arith-seed (rand-arg e) m seed)))
             ((rand (res-val x)) (res-state x)))]
          [(true? e) (res true seed)]
          [(false? e) (res false seed)]
          [(var? e) (res (get-mem e m) seed)]
          [(op? e)
           (let ((args (op-helper (op-args e) seed)))
             (res (apply (op->proc (op-op e))
                         (res-val args))
                  (res-state args)))]
          [(const? e) (res e seed)]))

  (define (new-eval e m seed) ;zwraca strukturę res, gdzie res-val to pamięć, a res-state to ziarno
    (cond [(assign? e)
           (let ((x (eval-arith-seed (assign-expr e) m seed)))
             (res (set-mem (assign-var e)
                           (res-val x)
                           m)
                  (res-state x)))]
          [(if? e)
           (let ((x (eval-arith-seed (if-cond e) m seed)))
             (if (res-val x)
                 (new-eval (if-then e) m (res-state x))
                 (new-eval (if-else e) m (res-state x))))]
          [(while? e)
           (let ((x (eval-arith-seed (while-cond e) m seed)))
             (if (res-val x)
                 (let ((y (new-eval (while-expr e) m (res-state x))))
                   (new-eval e (res-val y) (res-state y)))
                 (res m seed)))]
          [(block? e)
           (if (null? e)
               (res m seed)
               (let ((x (new-eval (car e) m seed)))
                 (new-eval (cdr e) (res-val x) (res-state x))))]))

  (res-val (new-eval e m seed)))

(define (run e)
  (eval e empty-mem initial-seed))

;;

(define fermat-test
  '{(composite := false)
    (while (and (> k 0) (not composite))
           ((a := (+ 2 (rand (- n 4))))
            (exp := 1)
            (i := 1)
            (while (< i n)
                   ((exp := (mod (* exp a) n))
                    (i := (+ i 1))))
            (if (= exp 1)
                (composite := false)
                (composite := true))
            (k := (- k 1))))})

(define (probably-prime? n k) ; check if a number n is prime using
  ; k iterations of Fermat's primality
  ; test
  (let ([memory (set-mem 'k k
                         (set-mem 'n n empty-mem))])
    (not (get-mem
          'composite
          (eval fermat-test memory initial-seed)))))

(probably-prime? 5 13)
(probably-prime? 345 20)

(run '(a := (+ 2 (rand 8765))))
(run '((b := (rand 42))
       (c := (rand 42))))
(run '(d := (rand (rand 142))))