collection.scm

;; The first three lines of this file were inserted by DrScheme.
;; They record information about the language level.
#reader(lib "plai-pretty-big-reader.ss" "plai")((modname collection) (read-case-sensitive #t) (teachpacks ()))
;AEfold : (lv rv -> rv) rv (list of lv) -> rv
;consumes an operation (f), a null value and a list; and operates f on the list at Scheme order
;Ex:
;(AEfold - 0 (1 2 3 4)) -> -8  ;(foldr - 0 '(1 2 3 4))->-2  , (foldl - 0 '(1 2 3 4)) -> 2
;(AEfold + 0 (3 5 7)) ->15   ;(foldr + 0 '(3 5 7)) ->15
;(AEfold / 1 (3 9 8)) -> 1/24 ; (foldr / 1 '(3 9 8)) -> 2 2/3 , (foldl / 1 '(3 9 8)) -> 2 2/3
;(AEfold / 1 (3 9 5 6)) -> 1/90 ; (foldr / 1 '(3 9 5 6)) ->5/18 , (foldl / 1 '(3 9 5 6))->3 3/5
;****foldr -> 5 / 6 -> 9*6 / 5 -> 3*5 / 9*6 -> 5/18
;****foldl -> 9 / 3 -> 5*3 / 9 -> 6*9 / 5*3 -> 3 3/5
;****AEfold -> 3 / 9 -> 3 / 9*5 -> 3 / 9*5*6 -> 1/90
;template:
;(define (AEfold f nv l)
;(if (null? l) nv
;      (f (last l)... (AEfold f nv (pre l)))    
;))
;; last -> (first (reverse l))  

(define (AEfoldin op nv list)  
  (cond
    ((null? list) nv)
    ((null? (rest list)) (AEfoldin op (op (first list) (op nv)) (rest list))) ;(op nv) => -3 vb icin 
    (else (AEfoldin op (op nv (first list)) (rest list)))))

(define (AEfold op nv list) (AEfoldin op nv (reverse list)))

(define-type OAI
  [num (n number?)]
  [id (name symbol?)]
  [add (operands (listof OAI?))]
  [sub (operands (listof OAI?))]
  [mul (operands (listof OAI?))]
  [div (operands (listof OAI?))]
  [ifexp (operands (listof OAI?))] 
  [with (name symbol?) (named-expr OAI?) (body OAI?)] ;(olsun (x (* 5 4))(+ x x))
)

(define (parse oexp)
 (cond
  [(number? oexp) (num oexp)]
  [(symbol? oexp) (id oexp)]
  [(not(list? oexp)) (error "expression is neither list nor a number")]
  ;[(> 3 (length oexp)) (error "expression is too short to be an olsun expression")]
  [(eqv? (first oexp) 'topla) (add (map parse (rest oexp)))]
  [(eqv? (first oexp) 'çıkart) (sub (map parse (rest oexp)))]
  [(eqv? (first oexp) 'çarp) (mul (map parse (rest oexp)))]
  [(eqv? (first oexp) 'böl) (div (map parse (rest oexp)))]
  [(eqv? (first oexp) 'eğer)
  (ifexp (map parse(cdr oexp)))]
   [(and (eqv? (first oexp) 'olsun) (= (length oexp) 3))
   (with (first(second oexp)) (parse (second (second oexp))) (parse (third oexp)))]
  [else "error unknown expression type"]
  )
)

;(parse '(olsun (x (topla 5 6)) (çıkart x 5)))
;(with 'x (add (list (num 5) (num 6))) (sub (list (id 'x) (num 5))))
;

(define (calc oexp)
  (type-case OAI oexp
  [num (n) n]
  [id (x) (error 'calc "free identifier")]
  [add (operands) (AEfold + 0 (map calc operands))]
  [sub (operands) (AEfold - 0 (map calc operands))]
  [mul (operands) (AEfold * 1 (map calc operands))]
  [div (operands) (AEfold / 1 (map calc operands))]
  [ifexp (operands) 
         ;(if (= 3 (length operands)) (if (= 0 (calc (first operands))) (calc (third oexp)) (calc (second oexp))) (error 'calc "too long to be an if-expression"))]           
  (if (= 3 (length operands)) 
                         (if  (eq? (calc (first operands)) 0) (calc (third operands)) (calc (second operands)))
                         (error 'calc "too long to be an if-expression"))]
         [with (bound-id named-expr bound-body)
        (calc (subst bound-body bound-id named-expr))]
 )
 )

(define (subst expr sub-id val)
  (type-case OAI expr
             [num (n) expr]
             [id (v) (if (symbol=? v sub-id) val expr)]
             [add (operands) (add (map (lambda (x) (subst x sub-id val)) operands))]
             [sub (operands) (sub(map (lambda (x) (subst x sub-id val)) operands))]
             [mul (operands) (mul(map (lambda (x) (subst x sub-id val)) operands))]
             [div (operands) (div(map (lambda (x) (subst x sub-id val)) operands))]
            [ifexp (operands) (ifexp (map (subst sub-id val) operands))]
             [with (bound-id named-expr bound-body)
                  (if (symbol=? bound-id sub-id)
                       (with bound-id (subst named-expr sub-id val) bound-body)
                       (with bound-id (subst named-expr sub-id val) (subst bound-body sub-id val)))]
             
    )
  )
"olsun expressions:"
(test  (calc (parse '(olsun (x (topla 5 6)) (çıkart x 5)))) 6)
(test  (calc (parse '(olsun (x (topla 5 6)) (çıkart 4 (topla x 5))))) -12)
(test  (calc (parse '(olsun (x (topla 5 6)) (çarp (çarp 3 x) 4 5)))) 660)
(test  (calc (parse '(olsun (x (topla 5 6)) (çarp (böl 3 x) 11 2)))) 6)
(test  (calc (parse '(olsun (x (topla 5 6)) (çarp (böl 3 x) 11 x)))) 33)
(test  (calc (parse '(olsun (x (topla 5 6)) (topla (çıkart (böl 3 x) 11 2) 9 4)))) 3/11)
(test (calc (parse '(eğer 2 3 4))) 3)
(test (calc (parse '(eğer 1 {böl 2 3} (çıkart 5 (böl 10 5))))) 2/3)



(define-type F1OAI
  [fnum (n number?)]
  [fadd (operands (listof F1OAI?))]
  [fsub (operands (listof F1OAI?))]
  [fmul (operands (listof F1OAI?))]
  [fdiv (operands (listof F1OAI?))]
  [fif-exp (lhs F1OAI?) (mid F1OAI?) (rhs F1OAI?)]
  [fwith (name symbol?) (named-expr F1OAI?) (body F1OAI?)]
  [fid (name symbol?)]
  [fapp (fun-name symbol?) (arg F1OAI?)]
)

;<fundef> ::= {<symbol> <symbol>  <LF1OAI>}
(define-type FunDef
  [fundef (fun-name symbol?) (arg-name symbol?) (body F1OAI?)])

;; lookup-fundef : symbol listof(FunDef) −! FunDef
;;consumes a function-name and a list of function-definitions and returns the matching function-definiton with the fun-name
(define (lookup-fundef fun-name fundefs) 
  (cond
    [(empty? fundefs) (error fun-name "function not found")]
    [else (if (symbol=? fun-name (fundef-fun-name (first fundefs))) (first fundefs)
          (lookup-fundef fun-name (rest fundefs)))])) 

;; fsubst : F1OAI symbol F1OAI -> F1OAI
(define (fsubst expr sub-id val)
  (type-case F1OAI expr
             [fnum (n) expr]
             [fadd (operands) (fadd (map (lambda (x) (fsubst x sub-id val)) operands))]
             [fsub (operands) (fsub (map (lambda (x) (fsubst x sub-id val)) operands))]
             [fmul (operands) (fmul (map (lambda (x) (fsubst x sub-id val)) operands))]
             [fdiv (operands) (fdiv (map (lambda (x) (fsubst x sub-id val)) operands))]
             [fif-exp (l m r) (fif-exp (fsubst  sub-id val l)
                                           (fsubst sub-id val m)
                                           (fsubst sub-id val r))]
             [fwith (bound-id named-expr bound-body) 
                   (if (symbol=? bound-id sub-id) (with bound-id (fsubst named-expr sub-id val) bound-body)
                       (with bound-id (fsubst named-expr sub-id val) (fsubst bound-body sub-id val)))]
             [fid (v) (if (symbol=? v sub-id) val expr)]
             [fapp (fun-name arg-expr) (fapp fun-name (fsubst arg-expr sub-id val))]
             
  ))

;; interp : F1OAI listof(fundef)-> number
(define (interp expr fun-defs)
  (type-case F1OAI expr
             [fnum (n) n]
             [fadd (operands) (AEfold + 0 (map (lambda (x) (interp x fun-defs)) operands))]
             [fsub (operands) (AEfold - 0 (map (lambda (x) (interp x fun-defs)) operands))]
             [fmul (operands) (AEfold * 1 (map (lambda (x) (interp x fun-defs)) operands))]
             [fdiv (operands) (AEfold / 1 (map (lambda (x) (interp x fun-defs)) operands))]
             [fif-exp (l m r) (if (eq? (interp fun-defs l) 0)
                                  (interp fun-defs m) (interp fun-defs r))]
             [fwith (bound-id named-expr bound-body)
                   (interp (fsubst bound-body 
                                  bound-id 
                                  (fnum (interp named-expr fun-defs))) fun-defs)]
             [fid (v) (error 'interp "free identifier")]
             [fapp (fun-name arg-expr) 
                  (local ([define the-fun-def (lookup-fundef fun-name fun-defs)])
                    (interp (fsubst (fundef-body the-fun-def)
                                   (fundef-arg-name the-fun-def)
                                   (fnum (interp arg-expr fun-defs))) fun-defs))]))

"function definitions:"
(test (interp (fapp 'toto (fnum 4)) (list (fundef 'toto 's (fdiv (list (fnum 4) (fid 's)))))) 1)
(test (interp (fapp 'double (fapp 'double {fnum 5})) (list (fundef 'double 'n (fadd (list (fid 'n) (fid 'n)))))) 20)
(test (interp (fapp 'f (fnum 5)) (list (fundef 'f 'n (fapp 'g (fadd (list (fid 'n) (fnum 5))))) (fundef 'g 'm (fsub (list (fid 'm) (fnum 1)))))) 9)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;no-more substitution- env!!!

(define (empty-env x) (error 'hede "undefined symbol"))

;; extend env id/value(pair) -> env
;; extend = (cons (cons id value) env)

(define (extend env id value) (lambda (tocheck-id) (if (equal? tocheck-id id) value (env tocheck-id))))
;; lookup env id -> value or error
;; lookup = assoc (scheme built in)

(define env1 (extend empty-env 'x 5))
(define env2 (extend env1 'y 6))

(test (env2 'y) 6)
(test (env2 'x) 5)
(test (env1 'x) 5)
;(env1 'y)
;(empty-env 'x)

;func-value has three parts:
;-formal-parameter
;-body
;-env

(define (make-func-value formal-param body env) (lambda (actual-param) (interp body (extend env formal-param actual-param))))

(define (make-env-rec formal-param body env)  ;make-func-value gibi
  (letrec ((newenv (extend env formal-param (interp body newenv)))) newenv ))
  


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (delay (+ 2 3))
;(delay ...)
; (force (delay (+ 2 3)))
;5


(define-macro (bug f)
  (quasiquote (lambda l
                (begin (newline) 
                       (display-sp (quote (unquote f)))
                       (map display-sp l)
                       (display-sp "=>")
                       (display-sp-val(apply (unquote f) l))))))


(define (display-sp x)
  (begin (display x) (display  " ")))

(define (display-sp-val x)
  (begin (display-sp x) x))

(define +$ (bug +))
(define -$ (bug -))
(define *$ (bug *))
(define /$ (bug /))


(define-macro (lazy-cons a b)
  (quasiquote (cons (delay (unquote a)) (delay (unquote b)))))

(define lazy-car
  (compose force car))

(define lazy-cdr
  (compose force cdr))

(define ones (lazy-cons 1 ones))

(define (force-list n tl)
  (if (<= n 0) null (cons (lazy-car tl) (force-list (sub1 n) (lazy-cdr tl)))))

;(force-list 10 ones)
;(list 1 1 1 1 1 1 1 1 1 1)

(define (lazy-map f . tll)
  (lazy-cons
   (apply f (map lazy-car tll))
   (apply lazy-map (cons f (map lazy-cdr tll)))))

;(force-list 10 (lazy-map + ones ones))
;(list 2 2 2 2 2 2 2 2 2 2)