;;;; ============================================================================================
;;;; some basic functions that are missing in some scheme implementations,
;;;; uncomment, if necessary
;;;; ============================================================================================

(define pi (* (acos 0) 2))

(define (add1 x) (+ x 1))

(define (sub1 x) (- x 1))

(define (id x) x)

(define (square x) (* x x))
 
(define writeln 
   (lambda args
      (for-each display args)
      (newline)))


;;;; =============================================================================================
;;;; random numbers
;;;; =============================================================================================

(define *last-ran* 1) ; the previous random number
(define (random-real)
  ;;; pick a random real number between 0 and 1.0
  (let* ((a (add1 (expt 2 7)))
         (b 1)
	 (T (sub1 (expt 2 35)))
	 (next-ran (remainder 
	            (+ (* a *last-ran*)
                       b)
                   T)))
         (set! *last-ran* next-ran)
	 (/ next-ran T)))

(define (random n)
  ;;; pick a random integer between 0 and n-1
  (inexact->exact (floor (* n (random-real)))))

;;; Choose an element from a list at random
(define (random-elt choices)
  (list-ref choices 
	   (random (length choices))))

(define (one-of set)
  ;;;Pick one element of set, and make a list of it.
       (list (random-elt set)))

;;;; =============================================================================================
;;;; Repetition
;;;; =============================================================================================

(define (until f end? seed)
  ; apply f to seed and repeat the process on the sequence of results (f (f (.. seed)))
  ; until (end? (f(f ..seed))) is satisfied. return the last value.
 (if (end? seed) seed
     (until f end? (f seed))))

(define (iterate f end? seed)
  ; apply f to seed and repeat the process on the sequence of results (f (f (.. seed)))
  ; until (end? (f(f ..seed))) is satisfied. return the last value.
 (letrec ((iteration 
	  (lambda (result nth-term)
	    (let ((new-term (f nth-term)))
	      (if (end? nth-term) result
		(iteration 
		  (cons new-term result)
		  new-term))))))
   (reverse 
    (iteration (list seed) seed))))

(define (reduce f xs seed)
  (cond ((null? xs) seed)
	(else
          (reduce f 
                  (cdr xs)
                  (f seed (car xs))))))

(define (filter p? xs)
  (cond ((null? xs) '()) ; fertig
        ((p? (car xs))
           (cons (car xs) 
                 (filter p? (cdr xs))))
        (else (filter p? (cdr xs)))))

;;;; =============================================================================================
;;;; The Dylan function builders, see Graham 96 for a Common Lisp Version
;;;; =============================================================================================
(define (always1 x)
  ;;; generate a function of one argument y returning constantly x.
  (lambda (y) x))

(define (always x)
  ;;; generate a function with an arbitrary number of arguments returning constantly x.
    (lambda args x))

(define (curry1 f x) 
  ;; curry left arg to the function f
        (lambda (y) (f x y)))

(define curry
  ;;; curry an arbitrary number of args (from left to right)
  ;;; to a function of several args.
  (lambda args ;function name and args to be curried
    (let ((f (car args))
	  (curried-args (cdr args)))
      (lambda not-curried-args
	(apply f 
	       (append
		 curried-args
		 not-curried-args))))))
(define rcurry
  ;;; curry an arbitrary number of args (as the last args)
  ;;; to a function of several args.
  (lambda args ;function name and args to be curried
    (let ((f (car args))
	  (curried-args (cdr args)))
      (lambda not-curried-args
	(apply f 
	       (append
		 not-curried-args
		 curried-args))))))

(define (compose2 f g)
  ;; compose two functions in one argument: (f (g x))
   (lambda (x) (f (g x))))

(define compose 
  ;; compose an arbitrary number of functions 
  (lambda functions
    (if (null? functions) id
	(let* ((rfs (reverse functions))
	       (f0  (car rfs))) 
	  ; the last function has to be applied first
	  (lambda fargs
	    (reduce
	     (lambda (v fi) (fi v)) 
	     ; apply function i to the previous result
	     (cdr rfs)
	     (apply f0 fargs))))))) ; the seed value
	  
(define disjoin 
  ;; return a composite predicate that is true 
  ;; when any of the component  predicates are true
  (lambda functions
    (if (null? functions) (always #f) ;no predicate is true
	(let ((f0 (car functions))
	      (rest (cdr functions)))
	  (lambda args
	    (or (apply f0 args)
		(apply (apply disjoin rest) args)))))))

(define conjoin 
  ;; return a composite predicate that is true 
  ;; when all of the component  predicates are true
  (lambda functions
    (if (null? functions) (always #t) ;all predicates are true
	(let ((f0 (car functions))
	      (rest (cdr functions)))
	  (lambda args
	    (and (apply f0 args)
		 (apply (apply disjoin rest) args)))))))

(define (nats-1-n n)
  ; make a list of 1 .. n 
    (iterate (curry + 1)
             (curry = n)
             1))
(define != (compose not =)) 

(define (odd n)
  (cond ((= 0 n) #f)
	((< n 0) (odd (abs n)))
	(else (even (- n 1)))))

(define (even n)
  (cond ((= 0 n) #t)
	(else (odd (- n 1)))))

;;;; =============================================================================================
;;;;               list processing tools
;;;; =============================================================================================

;;;; substitute elements of a list according to an association list with mappings
;;;; (sublis '( (1 . a) (2 . b) (3 . c))
;;;;         '( 1 2 3 1 2 4 3))  => (a b c a b 4 c)

(define (take n xs)
  ; the sublist of the first n elements of xs
  (cond 
   ((null? xs) '())
   ((= 0 n) '())
   (else (cons (car xs)
	       (take (- n 1) (cdr xs))))))

(define (drop n xs)
  ; drop the first n elements of xs and return the rest
  (cond 
   ((null? xs) '())
   ((= 0 n) xs)
   (else (drop (- n 1) (cdr xs)))))

(define (subseq xs from to)
 ; the sublist of xs starting by element 'from'
 ; and ending by elelmt 'to', zero indexed
  (take (add1 (- to from)) 
	(drop from xs)))

(define (position x xs start)
 ; at which position does x occur in xs (skipping up to start elements)?
  (letrec 
      ((locate
	(lambda (x xs pos)
	  (cond ((null? xs) #f)
		((equal? x (car xs)) pos)
		(else (locate x (cdr xs) (+ 1 pos)))))))
    (locate x (drop start xs) start)))
    
(define (sublis subs xs)
  (let ((replacement 
	 (lambda (x)
	   (let ((found (assoc x subs)))
	     (if (not found) x
		 (cdr found))))))
  (map replacement xs)))

(define (concat xss)
  ;; concatenate the sublists of a list of list
  (apply append xss))

(define (flatten ls)
  (cond  ((null? ls) '())
	 ((pair? (car ls))
	  (append (flatten (car ls))
		  (flatten (cdr ls))))
	 (else (cons (car ls)
		     (flatten (cdr ls))))))

;;; (flatten '(1 (2 (3 (4 ))))) => (1 2 3 4)

(define (mklist x)
  "Return x if it is a list, otherwise (x)."
  (if (listp x)
      x
      (list x)))

(define (mappend fn the-list)	
  "Apply fn to each element of list and append the results."
  (apply append (mapcar fn the-list)))

(define (some p? xs)
  ;; does some element of xs satisfy p?
  (if (null? xs) #f
      (let ((p (p? (car xs))))
	(if p p
	(some p? (cdr xs))))))

(define (every p? xs)
  ;; does each element of xs satisfy p?
  (if (null? xs) #t
      (reduce 
       (lambda (x1 x2)
	 (and x1 (p? x2)))
       (cdr xs)
       (p? (car xs)))))

;;;; =============================================================================================
;;;; Memoization
;;;; =============================================================================================
(define (fib n)
  "compute the n-th fibonacci number"
  (cond ((= 0 n) 1)
        ((= 1 n) 1)
        (else ( + (fib (- n 1))
               (fib (- n 2))))))

(define (fac n)
  (if (= n 0) 1 (* n (fac (- n 1)))))

(define (memo fn)
  "Return a memo-function of fn."
  (letrec 
    ((table '())
     (store 
      (lambda (arg val) 
	(set! table (cons (cons arg val) table))
	val))
     (retrieve 
      (lambda (arg) 
	(let ((val-pair (assoc arg table)))
	  (if val-pair (cdr val-pair) #f))))
     (ensure-val 
      (lambda (x)
	(let ((stored-val (retrieve x)))
	      (if stored-val stored-val
		  (store x (fn x)))))))
    ensure-val)) 
;;;; =============================================================================================
;;;; Ströme
;;;; =============================================================================================
;;; implementing stream functions in scheme

;; take first element from stream
(define (head stream)
            (car stream))

;; evaluate the rest of a stream
(define (tail stream)
  (cond ((null? stream) '())
	((null? (cdr stream)) '())
	((pair? (cdr stream)) (cdr stream))
	(else (force (cdr stream)))))

;; construct a stream
(define (cons-stream a b)
        (cons a (delay b)))

;; empty-stream?
(define (empty-stream? stream)
         (null? stream))

(define the-empty-stream 
      '())

(define (stream-ref stream i)
  "The i-th element of a stream, 0-based"
  (cond ((null? stream) #f)
	((= 0 i) (head stream))
	(else (stream-ref (tail stream) (- i 1)))))
;;;=================================
;;; higher order stream functions

;; map each element of a stream
(define (map-stream proc stream)
    (if (empty-stream? stream)
        the-empty-stream
        (cons
	 (proc (head stream))
	 (delay (map-stream proc (tail stream))))))

;; filter stream
(define (filter-stream pred? stream)
    (cond ((empty-stream? stream) the-empty-stream)
           ((pred? (head stream))
            (cons
	     (head stream)
	     (delay (filter-stream pred? (tail stream)))))
	   (else (filter-stream pred? (tail stream)))))

;; side effects
;; for-each
(define (for-each-stream proc stream)
    (cond ((empty-stream? stream)
        'done)
         (else (proc (head stream))
            (for-each-stream proc (tail stream)))))

(define (take-stream n stream)
  ; the sublist of the first n elements of xs
  (cond 
   ((empty-stream? stream) '())
   ((= 0 n) '())
   (else (cons (head stream)
	       (take-stream (- n 1) (tail stream))))))

(define (drop-stream n stream)
  ; drop the first n elements of xs and return the rest
  (cond 
   ((empty-stream? stream) '())
   ((= 0 n) stream)
   (else (drop-stream (- n 1) (tail stream)))))

(define  (append-streams x y)
  "Return a stream that appends the elements of x and y."
  (if (empty-stream? x)
      y
      (cons (head x)
	    (delay (append-streams (tail x) y)))))

(define (mappend-stream fn stream)
  "Lazily map fn over stream, appending results."
  (if (empty-stream? stream)
      the-empty-stream
      (let ((x (fn (head stream))))
        (cons
         (head x)
         (delay (append-streams 
	           (tail x)
	          (mappend-stream
		   fn (tail stream))))))))

(define (combine-all-streams xstream ystream)
 "Return a stream of streams formed by appending an x to an y."
 ; in other words: form the cartesian product.
 (mappend-stream
  (lambda (y)
      (map-stream 
        (lambda (x)
           (append-streams x y))
       xstream))
  ystream))

;;;===================================
;;; examples
(define (write-with-space x)
  (write x) (display " "))

(define (print-stream stream)
     (for-each-stream write-with-space stream)
     (writeln))

(define (integers-from-n n)
     (cons
         n
        (delay (integers-from-n (+ 1 n)))))  

(define (divisible? x y)
      (= (remainder x y) 0))

(define ints (integers-from-n 1))

(define no-sevens
     (filter-stream
        (lambda (x)
            (not (divisible? x 7)))
        ints))


;;;;;;; implementing delay and force
;;
(define (my-delay exp)
     (lambda () exp))

;;
(define (my-force delayed-object)
     (delayed-object))

(define (type-of x)
  (cond ((boolean?  x) 'boolean)
        ((pair? x) 'pair)
	((list? x) 'list)
	((symbol? x) 'symbol)
	((number? x) 'number)
	((char? x) 'char)
	((string? x) 'string)
	((vector? x) 'vector)
	((procedure? x) 'procedure)
	(else 'promise)))

(define (space n) 
   (until 
    (curry string-append " ")
    (compose (curry = n)
	    string-length)
    ""))