#lang pl 04

;; ================= Q1 & Q2 ====================

;; Defining two new types
(define-type BIT = (U 0 1))
(define-type Bit-List = (Listof BIT))

;; The actual interpreter
#| BNF for the ROL language:

 <ROL> ::= { reg-len = <num> <RegE>}

 <RegE> ::= {<Bits>}
          | {and <RegE> <RegE>}
          | {or <RegE> <RegE>}
          | {shl <RegE>}
          | {with {<id> <RegE>} <RegE>}
          | {fun { <id> } <RegE>}
          | {call <RegE> <RegE>}
          | <id>

 <Bits> ::= 0
          | 1
          | <Bits> ...

 |#
(define-type RegE
  [Reg Bit-List]
  [And RegE RegE]
  [Or RegE RegE]
  [Shl RegE]
  [Id Symbol]
  [With Symbol RegE RegE]
  [Fun Symbol RegE]
  [Call RegE RegE] )
;; Next is a technical function that converts (casts)
;; (any) list into a bit-list. We use it in parse-sexpr.
(: list->bit-list : (Listof Any) -> Bit-List)
;; to cast a list of bits as a bit-list
(define (list->bit-list lst)
  (cond [(null? lst) null]
        [(eq? (first lst) 1)
         (cons 1 (list->bit-list (rest lst)))]
        [else (cons 0 (list->bit-list (rest lst)))]))

(: parse-sexpr : Sexpr -> RegE)
;; to convert the main s-expression into ROL
(define (parse-sexpr sexpr)
  (match sexpr
    [(list 'reg-len '= (number: n) rest) (cond
                                           [(> n 0) (parse-sexpr-RegL rest n)]
                                           [else (error 'parse-sexpr "Register length must be at least 1")])]
    [else (error 'parse-sexpr "bad syntax in ~s" sexpr)]))

(: parse-sexpr-RegL : Sexpr Number -> RegE)
;; to convert s-expressions into RegEs
(define (parse-sexpr-RegL sexpr reg-len)
  (match sexpr
    [(list (and a (or 1 0)) ... ) (cond
                                    [(equal? (length a) reg-len) (Reg a)]
                                    [else (error 'parse-sexpr "wrong number of bits in ~s" a)])]
    [(list 'and l r) (And (parse-sexpr l) (parse-sexpr r))]
    [(list 'or l r) (Or (parse-sexpr l) (parse-sexpr r))]
    [(list 'shl reg) (Shl (parse-sexpr reg))]
    [(cons 'with more)
     (match sexpr
         [(list 'with (list (symbol: name) named) body)
          (With name (parse-sexpr named) (parse-sexpr body))]
         [else (error 'parse-sexpr "bad `with' syntax in ~s" sexpr)])]
    [(cons 'fun more)
     (match sexpr
         [(list 'fun (list (symbol: name)) body)
          (Fun name (parse-sexpr body))]
         [else (error 'parse-sexpr "bad `fun' syntax in ~s" sexpr)])]
    [(list 'call fun arg) (Call (parse-sexpr fun) (parse-sexpr arg))]
    [else (error 'parse-sexpr "bad syntax in ~s" sexpr)]))
(: parse : String -> RegE)
;; parses a string containing a RegE expression to a RegE AST
(define (parse str)
  (parse-sexpr (string->sexpr str)))

;; ================= Q3 ====================

(: subst : RegE Symbol RegE -> RegE)
;; substitutes the second argument with the third argument in the
;; first argument, as per the rules of substitution; the resulting
;; expression contains no free instances of the second argument   ....
#| Formal specs for `subst':
     (`BL' is a Bit-List, `E1', `E2' are <RegE>s, `x' is some <id>, `y' is a *different* <id>)
        BL[v/x]                = BL
        {and E1 E2}[v/x]      = {and E1[v/x] E2[v/x]}
        {or E1 E2}[v/x]       = {or E1[v/x] E2[v/x]}
        {shl E}[v/x]          = {shl E[v/x]}
        y[v/x]                = y
        x[v/x]                = v
        {with {y E1} E2}[v/x] = {with {y E1[v/x]} E2[v/x]}
        {with {x E1} E2}[v/x] = {with {x E1[v/x]} E2}
        {fun {y} E}[v/x]      = {fun {y} E[v/x]}
        {fun {x} E}[v/x]      = {fun {x} E}
        {call E1 E2}[v/x]     = {call E1[v/x] E2[v/x]}
|#
(define (subst e1 id e2)
  (cases e1
    [(Reg bit-list) e1]
    [(And l r) (And (subst l id e2) (subst r id e2))]
    [(Or l r) (Or (subst l id e2) (subst r id e2))]
    [(Shl e) (Shl (subst e id e2))]
    [(Id x) (if (equal? x id) e2 e1)]
    [(With x exp1 exp2) (if (equal? x id)
                            (With x (subst exp1 id e2) exp2)
                            (With x (subst exp1 id e2) (subst exp2 id e2)))]
    [(Fun bound-id bound-body)
       (if (eq? bound-id id)
         e1
         (Fun bound-id (subst bound-body id e2)))]
    [(Call l r) (Call (subst l id e2) (subst r id e2))]))

;; ================= Q4 ====================

(: reg-arith-op : (BIT BIT -> BIT) RegE RegE -> RegE)
;; Consumes two registers and some binary bit operation 'op',
;; and returns the register obtained by applying op on the
;; i'th bit of both registers for all i.
(define (reg-arith-op op reg1 reg2)
  (Reg (bit-arith-op op (Reg->bit-list reg1) (Reg->bit-list reg2))))

(: Reg->bit-list : RegE -> Bit-List)
(define (Reg->bit-list e)
  (cases e
    [(Reg n) n]
    [else (error 'reg-arith-op "expects a bit-list, got: ~s" e)]))

(: bit-arith-op : (BIT BIT -> BIT) Bit-List Bit-List -> Bit-List)
(define (bit-arith-op op bit-list1 bit-list2)
  (map op (bit-list1) (bit-list2)))

(: and-op : BIT BIT -> BIT)
(define (and-op bit1 bit2)
  (* bit1 bit2))

(: or-op : BIT BIT -> BIT)
(define (or-op bit1 bit2)
  (if (equal? (and-op bit1 bit2) 1)
           1
           (+ bit1 bit2)))

(: shl-op : Bit-List -> Bit-List)
(define (shl-op bitlist)
  (if (equal? (length bitlist) 1)
      bitlist
    (append (rest bitlist) (list (first bitlist)))))

(: eval : RegE -> RegE)
;; evaluates RegE expressions by reducing them to RegE that is
;; of the two variants (Reg..) or (Fun..)  ....
 #| Formal specs for `eval':
    eval(bl)          = bl
    eval({and E1 E2}) = (<x1 bit-and y1> <x2 bit-and y2> ... <xk bit-and yk>)
       where eval(E1) = (x1 x2 ... xk) and eval(E2) = (y1 y2 ... yk)

    eval({or E1 E2}) = (<x1 bit-or y1> <x2 bit-or y2> ... <xk bitor yk>)
      where eval(E1) = (x1 x2 ... xk) and eval(E2) = (y1 y2 ... yk)

    eval({shl E}) = (x2 ... xk x1), where eval(E) = (x1 x2 ... xk)
    eval(id)        = error!
    eval({with {x E1} E2}) = eval(E2[eval(E1)/x])
    eval(FUN) = FUN ;     assuming FUN is a function expression
    eval({call E1 E2}) = eval(Ef[eval(E2)/x])
                               if eval(E1)={fun {x} Ef}
                       = error!   otherwise
  |#
(define (eval expr)
  (cases expr
    [(Reg bit-list) expr]
    [(And l r) (reg-arith-op and-op (eval l) (eval l))]
    [(Or l r) (reg-arith-op or-op (eval l) (eval l))]
    [(Shl exp) (Reg (shl-op (Reg->bit-list (eval exp))))]
    [(With bound-id named-expr bound-body)
     (eval (subst bound-body
                  bound-id
                  (eval named-expr)))]
    [(Id name) (error 'eval "free identifier: ~s" name)]
    [(Fun bound-id bound-body) expr]
    [(Call fun-expr arg-expr)
     (let ([fval (eval fun-expr)])
       (cases fval
         [(Fun bound-id bound-body)
          (eval (subst bound-body
                       bound-id
                       (eval arg-expr)))]
         [else (error 'eval "`call' expects a function, got: ~s"
                      fval)]))]))

;; ================= Q5 ====================
(: run : String -> Bit-List)
;; evaluate a ROL program contained in a string
(define (run str)
  (let ([result (eval (parse str))])
    (cases result
      [(Reg n) n]
      [else (error 'run "evaluation returned a non-number: ~s" result)])))


;; tests
(test (run "{ reg-len = 4 {1 0 0 0}}") => '(1 0 0 0))
;;(test (run "{ reg-len = 4 {shl {1 0 0 0}}}") => '(0 0 0 1))
;;(test (run "{ reg-len = 4 {and {shl {1 0 1 0}}{shl {1 0 1 0}}}}") => '(0 1 0 1))
;;(test (run "{ reg-len = 4 { or {and {shl {1 0 1 0}} {shl {1 0 0 1}}} {1 0 1 0}}}") => '(1 0 1 1))
;;(test (run "{ reg-len = 2 { or {and {shl {1 0}} {1 0}} {1 0}}}") => '(1 0))
;;(test (run "{ reg-len = 4 {with {x {1 1 1 1}} {shl y}}}") =error> "free identifier")
;;(test (run "{ reg-len = 2 { with {x { or {and {shl {1 0}} {1 0}} {1 0}}} {shl x}}}") => '(0 1))
;;(test (run "{ reg-len = 4 {or {1 1 1 1} {0 1 1}}}") =error>"wrong number of bits in")
;;(test (run "{ reg-len = 0 {}}") =error> "Register length must be at least 1")
;;(test (run "{ reg-len = 3 {with {identity {fun {x} x}} {with {foo {fun {x} {or x {1 1 0}}}} {call {call identity foo} {0 1 0}}}}}"))