;; s-lists operations
;;
;; Following grammar:
;;
;; <s-list> ::= ()
;;             |    (<symbol-expression> . <s-list>)
;; <symbol-expression> ::= <symbol> | <s-list>
;;

(define s-list?
  (lambda (lst)
    (if (null? lst)
	#t
	(and
	 (list? lst)
	 (symbol-expression? (car lst))
	 (s-list? (cdr lst))))))

(define symbol-expression?
  (lambda (se)
    (or (symbol? se)
	(s-list? se))))

;; Inlining grammar/program:
;; 
;; <s-list> ::= ()
;;             |    (<symbol>|<s-list> . <s-list>)
;;

(define s-list?
  (lambda (lst)
    (if (null? lst)
	#t
	(and
	 (list? lst)
	 (or (symbol? (car lst)) (s-list? (car lst)))
	 (s-list? (cdr lst))))))

;; Following Kleene-star grammar:
;;
;; <s-list> ::= ({<symbol>|<s-list>}*)
;;

(define s-list?
  (lambda (lst)
    (and (list? lst)
	 (andmap (lambda (x) (or (symbol? x) (s-list? x))) lst))))



;; Well-formed lambda-calculus expression
;;
;; <lambda-expression> ::= <symbol>
;;                       | (lambda (<symbol>) <lambda-expression>)
;;                       | (<lambda-expression <lambda-expression>)

(define lambda-expression?
  (lambda (exp)
    (or (symbol? exp)
	(and (list? exp)
	     (or (and (= (length exp) 3)
		      (eq? 'lambda (car exp))
		      (and (list? (cadr exp)) (symbol? (caadr exp)))
		      (lambda-expression? (caddr exp)))
		 (and (= (length exp) 2)
		      (lambda-expression? (car exp))
		      (lambda-expression? (cadr exp))))))))

(lambda-expression? '(lambda (x) x))

(lambda-expression? '((lambda (x) x) y))

(lambda-expression? 'lambda)

(lambda-expression? '(lambda))

(lambda-expression? '(v v))

(lambda-expression? '(v v v))

(lambda-expression? '(lambda x x))

(lambda-expression? '((lambda (x) (x x)) (lambda (x) (x x))))

(lambda-expression? '((lambda (x) (x x))))


;; myvector->list
;; Recursion based on vector length

(define myvector->list
  (lambda (v)
    (myvector->list-from v 0)))

(define myvector->list-from
  (lambda (v n)
    (if (= n (vector-length v))
	'()
	(cons (vector-ref v n) 
	      (myvector->list-from v (+ n 1))))))

;; Alternative definition using letrec

(define myvector->list
  (lambda (v)
    (letrec
	((myvector->list-from
	  (lambda (n)
	    (if (= n (vector-length v))
		'()
		(cons (vector-ref v n) 
		      (myvector->list-from (+ n 1)))))))
      (myvector->list-from 0))))


;; Exercise 1.15 (9)

(define down
  (lambda (lst)
    (map list lst)))


;; Exercise 1.16 (1,5)

(define up 
  (lambda (lst)
    (if (null? lst)
	'()
	(if (list? (car lst))
	    (append (car lst) (up (cdr lst)))
	    (cons (car lst) (up (cdr lst)))))))

(define flatten 
  (lambda (lst)
    (if (null? lst)
	'()
	(if (list? (car lst))
	    (append (flatten (car lst)) (flatten (cdr lst)))
	    (cons (car lst) (flatten (cdr lst)))))))



;; Exercise 1.17 (2,3)

(define sort
  (lambda (lon)
    (if (null? lon)
	'()
	(insert (car lon) (sort (cdr lon))))))

(define insert
  (lambda (n lon)
    (if (or (null? lon) (< n (car lon)))
	(cons n lon)
	(cons (car lon) (insert n (cdr lon))))))

;; with higher-order predicate

(define sort
  (lambda (p lon)
    (if (null? lon)
	'()
	(insert p (car lon) (sort p (cdr lon))))))

(define insert
  (lambda (p n lon)
    (if (or (null? lon) (p n (car lon)))
	(cons n lon)
	(cons (car lon) (insert p n (cdr lon))))))


;; 
;; Exercise 1.31. for well-formed extended lambda calculus expressions
;;

(define lexical-address
  (lambda (exp)
    (lexical-address-env '() exp)))

(define lexical-address-env
  (lambda (env exp)
    (cond ((symbol? exp) (env-value env exp))
          ((eq? 'if (car exp))
           (cons 'if (map ((curry lexical-address-env) env) (cdr exp))))
          ((eq? 'lambda (car exp))
           (list 'lambda (cadr exp) 
                 (lexical-address-env (extend-env env (cadr exp)) (caddr exp))))
          (else (map ((curry lexical-address-env) env) exp)))))

(define env-value
  (lambda (env var)
     (if (null? env) 
         (list var 'free)
         (if (eq? var (caar env))
             (car env)
             (env-value (cdr env) var))))) 

(define extend-env
  (lambda (env formals)
    (add-replace-formals (inc-depth env) formals 0)))

(define inc-depth
  (lambda (env)
    (map 
      (lambda (varref)
        (list (car varref) ': (+ (caddr varref) 1) (cadddr varref)))
      env)))

(define add-replace-formals
  (lambda (env formals pos)
    (if (null? formals)
        env
        (add-replace-formals
          (add-replace-formal env (car formals) pos)
          (cdr formals) (+ pos 1)))))

(define add-replace-formal
  (lambda (env formal pos)
    (if (null? env)
        (list (list formal ': 0 pos))
        (if (eqv? (caar env) formal)
            (cons (list formal ': 0 pos)
                  (cdr env))
            (cons (car env)
                  (add-replace-formal (cdr env) formal pos))))))

;; Curry as combinator
(define curry
  (lambda (f)
    (lambda (x)
      (lambda (y)
        (f x y)))))

(lexical-address '(lambda (a b c)
                    (if (eqv? b c)
                       ((lambda (c)
                          (cons a c))
                        a)
                    b)))