LISTA 6

#lang racket

;; arithmetic expressions

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

(define (binop? t)
  (and (list? t)
       (= (length t) 3)
       (member (car t) '(+ - * /))))

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

(define (binop-left e)
  (cadr e))

(define (binop-right e)
  (caddr e))

(define (binop-cons op l r)
  (list op l r))

(define (arith-expr? t)
  (or (const? t)
      (and (binop? t)
           (arith-expr? (binop-left  t))
           (arith-expr? (binop-right t)))))

;; calculator

(define (op->proc op)
  (cond [(eq? op '+) +]
        [(eq? op '*) *]
        [(eq? op '-) -]
        [(eq? op '/) /]))

(define (eval-arith e)
  (cond [(const? e) e]
        [(binop? e)
         ((op->proc (binop-op e))
          (eval-arith (binop-left  e))
          (eval-arith (binop-right e)))]
        [(op? e)
         (apply
          (op->proc (op-op e))
          (map eval-arith (op-args e)))]))


;; let expressions

(define (let-def? t)
  (and (list? t)
       (= (length t) 2)
       (symbol? (car t))))

(define (let-def-var e)
  (car e))

(define (let-def-expr e)
  (cadr e))

(define (let-def-cons x e)
  (list x e))

(define (let? t)
  (and (list? t)
       (= (length t) 3)
       (eq? (car t) 'let)
       (andmap let-def? (cadr t))))

(define (let-def e)
  (car e))

(define (let-defs e)
  (cadr e))

(define (let-expr e)
  (caddr e))

(define (let-cons def e)
  (list 'let def e))

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

(define (var-var e)
  e)

(define (var-cons x)
  x)

(define (arith/let-expr? t)
  (or (const? t)
      (and (binop? t)
           (arith/let-expr? (binop-left  t))
           (arith/let-expr? (binop-right t)))
      (and (op? t)
           (andmap arith/let-expr? (op-args t)))
      (and (op? t)
           (andmap arith/let-expr? (op-args t)))
      (and (let? t)
           (arith/let-expr? (let-expr t))
           (arith/let-expr?-for-defs (let-defs t)))
      (var? t)))

(define (arith/let-expr?-for-defs e)
  (if (null? e)
      #t
      (and (arith/let-expr? (let-def-expr (let-def e)))
           (arith/let-expr?-for-defs (cdr e)))))

;; evaluation via substitution

(define (subst e x f)
  (cond [(const? e) e]
        [(binop? e)
         (binop-cons
           (binop-op e)
           (subst (binop-left  e) x f)
           (subst (binop-right e) x f))]
        [(let? e)
         (let-cons
           (let-def-cons
             (let-def-var (let-defs e))
             (subst (let-def-expr (let-defs e)) x f))
           (if (eq? x (let-def-var (let-defs e)))
               (let-expr e)
               (subst (let-expr e) x f)))]
        [(if-zero? e)
         (if-zero-cons
          (subst (if-zero-cond e) x f)
          (subst (if-zero-then e) x f)
          (subst (if-zero-else e) x f))]
        [(var? e)
         (if (eq? x (var-var e))
             f
             (var-var e))]))

(define (eval-subst e)
  (cond [(const? e) e]
        [(binop? e)
         ((op->proc (binop-op e))
            (eval-subst (binop-left  e))
            (eval-subst (binop-right e)))]
        [(op? e)
         (apply
          (op->proc (op-op e))
          (map eval-subst (op-args e)))]
        [(let? e)
         (eval-subst
           (subst
             (let-expr e)
             (let-def-var (let-defs e))
             (eval-subst (let-def-expr (let-defs e)))))]
        [(if-zero? e)
         (if (= (eval-subst (if-zero-cond e)) 0)
             (eval-subst (if-zero-then e))
             (eval-subst (if-zero-else e)))]
        [(var? e)
         (error "undefined variable" (var-var e))]))

;; evaluation via environments

(define empty-env
  null)

(define (add-to-env x v env)
  (cons (list x v) env))

(define (find-in-env x env)
  (cond [(null? env) (error "undefined variable" x)]
        [(eq? x (caar env)) (cadar env)]
        [else (find-in-env x (cdr env))]))

(define (eval-env e env)
  (cond [(const? e) e]
        [(binop? e)
         ((op->proc (binop-op e))
            (eval-env (binop-left  e) env)
            (eval-env (binop-right e) env))]
        [(op? e)
         (apply
          (op->proc (op-op e))
          (map (lambda (a) (eval-env a env))
               (op-args e)))]
        [(let? e)
         (eval-env
           (let-expr e)
           (env-for-let-defs (let-defs e) env))]
        [(if-zero? e)
         (if (= (eval-env (if-zero-cond e) env) 0)
             (eval-env (if-zero-then e) env)
             (eval-env (if-zero-else e) env))]
        [(var? e) (find-in-env (var-var e) env)]))

(define (env-for-let-defs defs env)
  (if (null? defs)
      env
      (env-for-let-defs (cdr defs) (env-for-let (let-def defs) env))))

(define (env-for-let def env)
  (add-to-env
    (let-def-var def)
    (eval-env (let-def-expr def) env)
    env))

(define (eval e)
  (eval-env e empty-env))


;; cwiczenia

;; cw. 2

(define (stack? s) (list? s))

(define empty-stack null)

(define (push e s) (cons e s))

(define (pop s) (cons (car s) (cdr s)))

;; cw. 1

(define (arith->rpn e)
  (define (aux s e)
    (cond [(const? e) (push e s)]
          [(binop? e)
           (let ((op (binop-op e))
                 (l (binop-left e))
                 (r (binop-right e)))
             (aux (aux (push op s) r)
                  l))]))
  (aux empty-stack e))

;; cw. 3

(define (eval-rpn e)
  (define (aux e s)
    (cond [(null? e) (car (pop s))]
          [(const? (car e))
           (aux (cdr e) (push (car e) s))]
          [(symbol? (car e))
           (aux (cdr e)
                (push
                 ((op->proc (car e))
                  (car (pop (cdr (pop s))))
                  (car (pop s)))
                 (cdr (pop (cdr (pop s))))))]))
  (aux e empty-stack))

;; cw. 4

; / 7 + 2 3
; calc let x 3 x lambda x + x 2

;; cw. 5

; ewaluacja if-zero w let-wyrażeniach

(define (if-zero? e)
  (and (list? e)
       (= (length e) 4)
       (eq? (car e) 'if-zero)))

(define (if-zero-cons c t e)
  (cons 'if-zero (list c t e)))

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

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

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

;; cw. 6

; operacje arytmetyczne o dow. ilosci argumentow

(define (op? e)
  (and (list? e)
       (member (car e) '(+ - * /))))

(define (op-cons op args) (cons op args))

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

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

;; cw. 7

; zamiana składni i ewaluacji let-wyrażeń
; nie działa subst, eval-subst dla leta

;; cw. 8

; NOT IMPLEMENTED YET I TYLE