;;;; file: samples.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de
;;;; Date: Mar 29, 2009
;;;;       Apr 17, 2009
;;;;       Apr 27, 2009
;;;;       May 01,  2009
;;;;       May 19, 2009
;;;;       Nov 23, 2009
;;;;       Feb 02, 2010
;;;;       Jul 09, 2010
;;;;       Jul 12, 2010
;;;;       Aug 06, 2010
;;;;       Sep 09, 2010
;;;;       Jan 09, 2011

(require 'contracts)

(module samples ;*
  (nil create-list enum sublist list-head vector-append index
       random-list memp vector-head vector-tail string-head string-tail flat?
       filter sieve fold-left fold-right fold-mapped last append-item map*
       filter* plength listify unlist pmap pmap* pflatten pflat? cons* 
       space spaces writesp displaysp writeln displayln curry uncurry
       quotient+remainder pairs+atoms yes+no samples)

  (import scheme
    contracts
    (only chicken add1 sub1 cut)
    (only extras random)
    (only srfi-102 procedure-arity-includes?)
    ; note, that the procedures whose arity is tested, have
    ; sometimes to be converted to the exact arity, e.g.
    ; (lambda (a b) (* a b)) instead of simply *
    (only data-structures flatten list-of? o))

  ;; initialize documentation
  (doclist '())

  ;;; copied from basics, so that it needn't not to be imported
  (define cardinal?
    (lambda (x)
      (and (integer? x) (exact? x) (or (zero? x) (positive? x)))))

  ;;;; procedure processing routines

  (define-with-contract (curry proc)
    "transforms a procedure of n+1 arguments "
    "into a procedure with one argument "
    "returning a procedure with n arguments"
    (domain: (procedure? proc))
    (range: (procedure? result))
    (lambda (arg)
      (lambda args
        (apply proc (cons arg args)))))

  (define-with-contract (uncurry proc)
    "transforms a procedure of one argument "
    "which returns a procedure of n arguments "
    "into a procedure with n+1 arguments"
    (domain: (procedure? proc))
    (range: (procedure? result))
    (lambda (arg . args)
      (apply (proc arg) args)))

  ;;;; number processing routines ;;;;

  (define-with-contract (quotient+remainder m n)
    "integer division with Euclid's algorithm"
    (results: q r)
    (domain:
      (integer? m)
      (not (negative? m))
      (integer? n)
      (positive? n)
      (<= n m))
    (range:
      (integer? q)
      (integer? r)
      (= (+ (* q n) r) m))
    (let loop ((q 0) (r m))
      (if (< r n)
        (values q r)
        (loop (add1 q) (- r n)))))

  ;;;; vector processing routines ;;;;

  (define-with-contract (vector-tail vec from)
    "returns the tail of a vector"
    (domain: (vector? vec) (cardinal? from)
             (<= from (vector-length vec)))
    (range: (vector? result)
            (= (+ from (vector-length result)) (vector-length vec)))
    (let* (
           (len (vector-length vec))
           (new-len (- len from))
           (result (make-vector new-len #f))
           )
      (let loop ((k 0))
        (if (= k new-len)
          result
          (begin
            (vector-set! result k (vector-ref vec (+ k from)))
            (loop (add1 k)))))))

  (define-with-contract (vector-head vec upto)
    "returns the head of a vector"
    (domain: (vector? vec) (cardinal? upto)
             (<= upto (vector-length vec)))
    (range: (vector? result)
            (= (vector-length result) upto))
    (let ((new (make-vector upto #f)))
      (let loop ((n 0))
        (if (= n upto)
          new
          (begin
            (vector-set! new n (vector-ref vec n))
            (loop (add1 n)))))))

  (define-with-contract (vector-append vec1 vec2)
    "appends two vectors"
    (domain: (vector? vec1) (vector? vec2))
    (range: (vector? result)
            (equal? (vector-head result (vector-length vec1)) vec1)
            (equal? (vector-tail result (vector-length vec1)) vec2))
    (let ((len1 (vector-length vec1)) (len2 (vector-length vec2)))
      (let ((vec (make-vector (+ len1 len2) #f)))
        (let loop ((n 0))
          (if (= n (+ len1 len2))
            vec
            (begin
              (if (< n len1)
                (vector-set! vec n (vector-ref vec1 n))
                (vector-set! vec n (vector-ref vec2 (- n len1))))
              (loop (add1 n))))))))

  ;;;; string processing routines ;;;;

  (define-with-contract (string-tail str from)
    "returns the tail of a string"
    (domain: (string? str) (cardinal? from)
             (<= from (string-length str)))
    (range: (string? result)
            (= (+ from (string-length result)) (string-length str)))
    (substring str from (string-length str)))

  (define-with-contract (string-head str upto)
    "returns the head of a string"
    (domain: (string? str) (cardinal? upto)
             (<= upto (string-length str)))
    (range: (string? result)
            (= (string-length result) upto))
    (substring str 0 upto))

  ;;;; list processing routines ;;;;

  (define nil '())

  (define-with-contract (filter ok? lst)
    "remove items of argument list, which are not ok?"
    (domain: (procedure? ok?) (list? lst))
    (range: (list? result)
            (<= (length result) (length lst)))
    (let loop ((lst lst) (acc '()))
      (if (null? lst)
        (reverse acc)
        (let ((val (car lst)))
          (if (ok? val)
            (loop (cdr lst) (cons val acc))
            (loop (cdr lst) acc))))))

  (define-with-contract (yes+no ok? lst)
    "splits a list according to a predicate"
    (results: yes no)
    (domain: (procedure? ok?) (list? lst))
    (range: (list? yes) (list? no)
            (= (length lst) (+ (length yes) (length no))))
    (let loop ((lst lst) (yes '()) (no '()))
      (cond
        ((null? lst)
         (values (reverse yes) (reverse no)))
        ((pair? lst)
         (let ((val (car lst)))
           (loop (cdr lst)
                 (if (ok? val) (cons val yes) yes)
                 (if (ok? val) no (cons val no)))))
        (else
          (if (ok? lst)
            (values (append (reverse yes) lst) (reverse no))
            (values (reverse yes) (append (reverse no) lst)))))))

  (define-with-contract (pairs+atoms lst)
    "splits a list into pairs and atoms"
    (results: pairs atoms)
    (domain: (list? lst))
    (range: (list? pairs) (list? atoms)
            (= (length lst) (+ (length pairs) (length atoms))))
    ;  (let loop ((lst lst) (pairs '()) (atoms '()))
    ;    (cond
    ;      ((null? lst)
    ;       (values (reverse pairs) (reverse atoms)))
    ;      ((not (pair? lst))
    ;       (values (reverse pairs) (append (reverse atoms) lst)))
    ;      (else
    ;        (let ((val (car lst)))
    ;          (loop (cdr lst)
    ;                (if (pair? val) (cons val pairs) pairs)
    ;                (if (pair? val) atoms (cons val atoms)))))))))
    (yes+no pair? lst))

  (define-with-contract (list-head lst upto)
    "returns the head of a list"
    (domain: (list? lst) (cardinal? upto)
             (<= upto (length lst)))
    (range: (list? result)
            (= (length result) upto))
    (let loop ((lst lst) (n upto) (head '()))
      (if (zero? n)
        (reverse head)
        (loop (cdr lst)
              (sub1 n)
              (cons (car lst) head)))))

  (define-with-contract (sublist lst lo hi)
    "extract a sublist from lo (included) to hi (excluded)"
    (domain: (list? lst)
             (cardinal? lo)
             (cardinal? hi)
             (<= lo hi (length lst))
             (< lo (length lst)))
    (range: 
      (list? result)
      (= (length result) (- hi lo)))
    (list-head (list-tail lst lo) (- hi lo)))

  (define-with-contract (create-list start stop? next)
    "creates a freshly consed list"
    (domain: (procedure? stop?) (procedure? next))
    (range: (list? result)
            (null? (filter stop? result))
            (not (null? result))
            (equal? (car result) start))
    (let loop ((x start) (acc '()))
      (if (stop? x)
        (reverse acc)
        (loop (next x) (cons x acc)))))

  (define-with-contract (enum n)
    "create list of positive integers less then n"
    (domain: (cardinal? n))
    (range: (list? result)
            ((list-of? cardinal?) result)
            (= (length result) n))
    (let loop ((acc '()) (n (sub1 n)))
      (if (< n 0)
        acc
        (loop (cons n acc) (sub1 n)))))

  (define-with-contract (random-list n)
    "create a list of random numbers from [0 n[" 
    (domain: (cardinal? n))
    (range: (list? result) (= n (length result)))
    (let loop ((acc '()) (k n))
      (if (zero? k)
        acc
        (loop (cons (random n) acc) (- k 1)))))

  (define-with-contract (memp ok? lst)
    "find the sublist which starts with an item fullfilling ok?"
    (domain: (procedure? ok?) (list? lst))
    (range:
      (or (list? result) (and (boolean? result) (not result)))
      (if (list? result) (<= (length result) (length lst))))
    (let loop ((lst lst))
      (cond
        ((null? lst) #f)
        ((ok? (car lst)) lst)
        (else
          (loop (cdr lst))))))

  (define-with-contract (sieve compare? lst)
    "sieve of Eratosthenes"
    (domain:
      (procedure? compare?)
      (procedure-arity-includes? compare? 2)
      (list? lst))
    (range: (list? result)
            (<= (length result) (length lst))
            "no two items of result compare?")
    (let loop ((lst lst) (acc '()))
      (if (null? lst)
        (reverse acc)
        (let ((first (car lst)) (rest (cdr lst)))
          (loop (filter
                  (lambda (x) (not (compare? x first)))
                  rest)
                (cons first acc))))))

  (define-with-contract (fold-right op base . lsts)
    "right-folding list of lists with op starting with base"
    (domain:
      ((list-of? list?) lsts)
      ;; all of equal length
      (null? (cdr (sieve (cut = <> <>) (map length lsts))))
      (procedure? op)
      (procedure-arity-includes? op (add1 (length lsts))))
    (let helper ((lsts lsts))
      (if ((list-of? null?) lsts)
        base
        (apply op
               (append (map car lsts)
                       (list (helper (map cdr lsts))))))))

  (define-with-contract (fold-left op base . lsts)
    "left-folding list of lists with op starting with base"
    (domain:
      ((list-of? list?) lsts)
      ;; all of equal length
      (null? (cdr (sieve (cut = <> <>) (map length lsts))))
      (procedure? op)
      (procedure-arity-includes? op (add1 (length lsts))))
    (let loop ((base base) (lsts lsts))
      (if ((list-of? null?) lsts)
        base
        (loop (apply op (cons base (map car lsts)))
              (map cdr lsts)))))

  (define-with-contract (fold-mapped op base fn . lsts)
    "combination of left-folding and mapping"
    (domain:
      ((list-of? list?) lsts)
      ;; all of equal length
      (null? (cdr (sieve (cut = <> <>) (map length lsts))))
      (procedure? op)
      (procedure-arity-includes? op 2)
      (procedure? fn)
      (procedure-arity-includes? fn (length lsts)))
    (let ((lst (apply map fn lsts)))
      (fold-left op base lst)))

  (define-with-contract (last lst)
    "returns the last item of a list"
    (domain: (list? lst) (not (null? lst)))
    (range: (null? (cdr (member result lst))))
    (let loop ((lst lst) (result (car lst)))
      (if (null? (cdr lst)) result (loop (cdr lst) (cadr lst)))))

  (define-with-contract (flat? xpr)
    "checks if xpr is a flat list"
    (cond
      ((not (list? xpr)) #f)
      ((null? xpr) #t)
      ((and (pair? xpr) (null? (car xpr))) #f)
      ((and (pair? xpr) (pair? (car xpr))) #f)
      (else (flat? (cdr xpr)))))

  (define-with-contract (append-item lst item)
    "appends an item to a list"
    (domain: (list? lst))
    (range: (list? result)
            (= (length result) (+ (length lst) 1))
            (equal? (list-head result (length lst)) lst)
            (equal? (last result) item))
    (append lst (list item)))

(define-with-contract (map* fn lst)
  "deeply map a nested list"
  (domain:
    (procedure? fn)
    (procedure-arity-includes? fn 1)
    (list? lst))
  (range: (list? result))
  (map (lambda (sublst)
         (if (pair? sublst)
           (map* fn sublst)
           (fn sublst)))
       lst))

(define-with-contract (filter* ok? lst)
  "deeply filter a nested list"
  (domain:
   (procedure? ok?)
   (procedure-arity-includes? ok? 1)
   (list? lst))
  (range: (list? result))
  (if (null? lst)
    '()
    (let (
      (first (car lst))
      (rest (cdr lst))
      )
      (if (list? first)
        (cons (filter* ok? first) (filter* ok? rest))
        (if (ok? first)
          (cons first (filter* ok? rest))
          (filter* ok? rest))))))

(define-with-contract (index sym syms)
  "returns the index of a symbol in a symlist of #f"
  (domain: (symbol? sym) ((list-of? symbol?) syms))
  (range: (or (not result) (and (cardinal? result) (< result (length syms)))))
  (let loop ((ind 0) (syms syms))
    (cond
      ((null? syms) #f)
      ((eq? sym (car syms)) ind)
      (else
        (loop (add1 ind) (cdr syms))))))

;;;; pseudolist processing routines ;;;;

(define-with-contract (cons* . args)
  "pseudolist constructor a la MIT-Scheme"
  (domain: (list? args))
  (range: (if (null? args)
            (null? result)
            (or (pair? result) (not (list? result)))))
  (if (null? args)
    '()
    (if (null? (cdr args))
      (car args)
      (cons (car args) (apply cons* (cdr args))))))

(define-with-contract (listify xpr)
  "add trailing '() to an atom or a pseudolist"
  (domain:)
  (range: (list? result))
  (cond
    ((list? xpr) xpr)
    ((not (pair? xpr)) (list xpr))
    (else (cons (car xpr) (listify (cdr xpr))))))

(define-with-contract (unlist lst)
  "remove the trailing '() of a list"
  (domain: (list? lst) (not (null? lst)))
  (if (null? (cdr lst))
    (car lst)
    (cons (car lst) (unlist (cdr lst)))))

(define-with-contract (plength plst)
  "pseudolist length"
  (domain:)
  (range: (cardinal? result) (positive? result))
  (if (list? plst)
    (length plst)
    (let loop ((result 0) (plst plst))
      (if (not (pair? plst))
        (add1 result)
        (loop (add1 result) (cdr plst))))))

(define-with-contract (pflat? xpr)
  "checks if xpr is a flat pseudolist and not a list"
  (cond
    ((list? xpr) #f)
    ((not (pair? xpr)) #t)
    (else
      (and (not (pair? (car xpr)))
           (pflat? (cdr xpr))))))

(define-with-contract (pflatten plst)
  "flatten a nested pseudo-list"
  (domain:)
  (range: (and (list? result) (flat? result)))
  (cond 
    ((pair? plst)
     (append (pflatten (car plst)) (pflatten (cdr plst))))
    ((null? plst) '())
    (else (list plst))))

(define-with-contract (pmap fn . xprs) 
  "map flat pseudolists with fn"
  (domain:
    (not (null? xprs))
    ((list-of? (o not list?)) xprs)
    (or ((list-of? pair?) xprs)
        ((list-of? (o not pair?)) xprs))
    ;; all of equal plength
    (null? (cdr (sieve (cut = <> <>)  (map plength xprs))))
    (procedure? fn)
    (procedure-arity-includes? fn (length xprs)))
  (let helper ((xprs xprs))
    (cond
      (((list-of? null?) xprs)
       '())
      (((list-of? (o not pair?)) xprs)
       (let ((val (apply fn xprs)))
         (if (list? val) `(,val) val)))
      (else
        (cons (apply fn (map car xprs))
              (helper (map cdr xprs)))))))

(define-with-contract (pmap* fn xpr)
  "map a nested pseudolist with fn"
  (domain: (procedure? fn)
           (procedure-arity-includes? fn 1))
  (cond
    ((pair? xpr)
     (cons (pmap* fn (car xpr)) (pmap* fn (cdr xpr))))
    ((null? xpr) '())
    (else (fn xpr))))
;    (pmap (lambda (subxpr)
;           (if (pair? subxpr)
;             (pmap* fn subxpr)
;             (fn subxpr)))
;         xpr)))

;;;; output routines ;;;;

(define-with-contract (space)
  "display space"
  (display " "))

(define-with-contract (spaces n)
  "display n spaces"
  (domain: (cardinal? n))
  (if (= n 1)
    (display " ")
    (begin
      (display " ")
      (spaces (- n 1)))))

(define-with-contract (writesp arg)
  "write arg with trailing space"
  (write arg)
  (space))

(define-with-contract (displaysp arg)
  "display arg with trailing space"
  (display arg)
  (space))

(define-with-contract (writeln arg)
  "write arg with trailing newline"
  (write arg)
  (newline))

(define-with-contract (displayln arg)
  "display arg with trailing newline"
  (display arg)
  (newline))

(define samples (doclist->dispatcher (doclist)))

) ; module samples

;(import samples contracts)