#|[
Author: Juergen Lorenz
ju (at) jugilo (dot) de

Copyright (c) 2014, Juergen Lorenz
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

Neither the name of the author nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission. 

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
]|#

(require-library datatype)

(functor (typed-lists (M (type? equ?)))
  ;;functor exports
  (typed-lists typed-list? typed-list untyped-list->typed-list typed-list->untyped-list
   list-apply list-null list-null? list-cons list-first list-rest list-reverse
   list-length list-item list-map list-for-each list-append list-mappend
   list-from-upto list-split-at list-split-with list-equal? list-member
   list-memp list-remp list-remove list-remove-dups list-assp list-assoc
   list-filter list-fold-left list-fold-right list-merge list-sort list-sorted?
   list-drop list-drop-while list-take list-take-while list-repeat list-iterate
   list-iterate-while list-iterate-until list-zip list-interpose list-every?
   list-some list-not-every? list-not-any? list-in? list-bind
   ;sets
   sets set? set typed-list->set set->typed-list set-in?  set-cardinality
    set-filter set-null? set-difference set-add set-remove
    set= set>= set<= set-union set-intersection)


(import scheme
        (only chicken error define-record-printer
              unless receive case-lambda)
        (only data-structures list-of? o compose)
        (only extras sprintf)
        datatype
        M)

(import-for-syntax (only chicken receive print))

(define-datatype typed-list typed-list?
  (list-null)
  (list-cons
    (first type?)
    (rest typed-list?)))

(define-record-printer (typed-list tlst out)
  (let ((str (sprintf "~s" (typed-list->untyped-list tlst))))
    (string-set! str (- (string-length str) 1) #\])
    (string-set! str 0 #\[)
    (display str out)))

;(define-reader-ctor 'typed typed-list)

(define (list-null? xpr)
  (and (typed-list? xpr)
       (cases typed-list xpr
         (list-null () #t)
         (list-cons (first rest) #f))))

(define (list-first lst)
  (cases typed-list lst
    (list-null () (error 'list-first "list empty" lst))
    (list-cons (first rest) first)))

(define (list-rest lst)
  (cases typed-list lst
    (list-null () (error 'list-rest "list empty" lst))
    (list-cons (first rest) rest)))

(define-syntax list-bind
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat (cadr form))
            (tlst (caddr form))
            (xpr (caddr form))
            (xprs (cdddr form)))
        (let ((tlst tlst))
                    ;; not available at compile time
                    ;(if (typed-list? tlst)
                    ;  tlst
                    ;  (error 'list-bind
                    ;         "not a typed list"
                    ;         tlst))))
          (if (list? pat)
            `(if (= ,(length pat) (list-length ,tlst))
               (list-apply (lambda ,pat ,xpr ,@xprs) ,tlst)
               (error 'list-bind "match error" ',pat ,tlst))
            ;; pseudolist: separate list part
            (receive (head tail)
              (let loop ((pat pat) (lst '()))
                (if (pair? pat)
                  (loop (cdr pat) (cons (car pat) lst))
                  (values (reverse lst) pat)))
              `(if (<= ,(length head) (list-length ,tlst))
                 (receive (hd tl) (list-split-at ,(length head) ,tlst)
                   (let ((,tail tl))
                     (list-apply (lambda ,head ,xpr ,@xprs) hd)))
                 (error 'list-bind "match error" ',pat ,tlst)))))))))

(define (list-reverse . lsts)
  (cond
    ((null? lsts)
     (list-null))
    ((null? (cdr lsts))
     (let loop ((ls (car lsts)) (result (list-null)))
       (cases typed-list ls
         (list-null () result)
         (list-cons (first rest)
                    (loop rest (list-cons first result))))))
    (else
      (let loop (
        (lsts lsts)
        (results ;(make-list (length lsts) (list-null)))
                 (let recur ((n (length lsts))
                             (result '()))
                   (if (zero? n)
                     result
                     (recur (- n 1) (cons (list-null) result)))))
        )
        (cond
          (((list-of? list-null?) lsts)
           (apply values results))
          (((list-of? (o not list-null?)) lsts)
           (loop (map list-rest lsts)
                 (map (lambda (l ll) (list-cons l ll))
                      (map list-first lsts)
                      results)))
          (else (error 'list-reverse "lists not of equal length")))))))

(define (typed-list . args)
  (let loop ((args args) (result (list-null)))
    (if (null? args)
      (list-reverse result)
      (loop (cdr args) (list-cons (car args) result)))))

(define (list-repeat n x)
  (let loop ((k 0) (result (list-null)))
    (if (= k n)
      result
      (loop (+ k 1) (list-cons x result)))))

(define (list-iterate n fn x)
  (let loop ((k 0) (val x) (result (list-null)))
    (if (= k n)
      (list-reverse result)
      (loop (+ k 1) (fn val) (list-cons val result)))))

(define (list-iterate-while ok? fn x)
  (let loop ((val x) (result (list-null)))
    (if (ok? val)
      (loop (fn val) (list-cons val result))
      (list-reverse result))))

(define (list-iterate-until ok? fn x)
  (let loop ((val x) (result (list-null)))
    (if (ok? val)
      (list-reverse result)
      (loop (fn val) (list-cons val result)))))

(define (typed-list->untyped-list lst)
  (let loop ((ls lst) (result '()))
    (cases typed-list ls
      (list-null () (reverse result))
      (list-cons (first rest)
       (loop rest (cons first result))))))

(define (list-apply fn . args)
  (let ((len (length args)))
    (apply fn
      (let loop ((k 0) (result '()))
        (cond
          ((= k len) (reverse result))
          ((= k (- len 1))
           (let ((tail (list-ref args k)))
             (if (typed-list? tail)
               (loop (+ k 1)
                     (append
                       (reverse
                         (typed-list->untyped-list tail))
                       result))
               (error 'list-apply
                      (string-append
                        "not a "
                        (symbol->string
                          'tlist))
                      tail))))
          (else
            (let ((item (list-ref args k)))
              (if (type? item)
                (loop (+ k 1)
                      (cons item result))
                (error 'list-apply
                       "wrong list-ype"
                       `(,type? ,item))))))))))

(define (untyped-list->typed-list lst)
  (apply typed-list lst))

(define (list-length lst)
  (let loop ((ls lst) (k 0))
    (cases typed-list ls
      (list-null () k)
      (list-cons (first rest)
        (loop rest (+ k 1))))))

(define (list-item k lst)
  (let loop ((ls lst) (n 0))
    (cases typed-list ls
      (list-null () (error 'list-item "range error"))
      (list-cons (first rest)
        (if (= n k)
          first
          (loop rest (+ n 1)))))))

(define (list-from-upto from upto lst)
  (let loop ((ls lst) (k 0) (result (list-null)))
    (cases typed-list ls
      (list-null () (list-reverse result))
      (list-cons (first rest)
        (cond
          ((= k upto)
           (list-reverse result))
          ((< k from)
           (loop rest (+ k 1) result))
          (else
            (loop rest (+ k 1) (list-cons first result))))))))

(define (list-split-at k lst)
  (let loop ((ls lst) (n 0) (head (list-null)))
    (cases typed-list ls
      (list-null () (values (list-reverse head) ls))
      (list-cons (first rest)
        (if (= n k)
         (values (list-reverse head) ls)
         (loop rest (+ n 1) (list-cons first head)))))))

(define (list-split-with ok? lst)
  (let loop ((ls lst) (head (list-null)))
    (cases typed-list ls
      (list-null () (values (list-reverse head) ls))
      (list-cons (first rest)
        (if (ok? first)
          (values (list-reverse head) ls)
          (loop rest (list-cons first head)))))))

(define (list-take k lst)
  (call-with-values
    (lambda () (list-split-at k lst))
    (lambda (head tail) head)))

(define (list-take-while ok? lst)
  (call-with-values
    (lambda () (list-split-with (o not ok?) lst))
    (lambda (head tail) head)))

(define (list-drop k lst)
  (call-with-values
    (lambda () (list-split-at k lst))
    (lambda (head tail) tail)))

(define (list-drop-while ok? lst)
  (call-with-values
    (lambda () (list-split-with (o not ok?) lst))
    (lambda (head tail) tail)))

(define (list-append . lsts)
  (cond
    ((null? lsts)
     (list-null))
    ((null? (cdr lsts))
     (car lsts))
    ((null? (cddr lsts))
     (let loop ((ls0 (list-reverse (car lsts)))
                (result (cadr lsts)))
       (cases typed-list ls0
         (list-null () result)
         (list-cons (first rest)
                 (loop rest (list-cons first result))))))
    (else
      (list-append (car lsts)
                (apply list-append (cdr lsts))))))

(define (list-mappend fn . lsts)
  (apply list-append
         (apply map fn
                (map typed-list->untyped-list lsts))))

(define (list-map fn . lsts)
  (if (null? lsts)
    (list-null)
    (let loop ((lsts lsts) (result (list-null)))
      (if (memq #t (map list-null? lsts))
        (list-reverse result)
        (loop (map list-rest lsts)
              (list-cons (apply fn (map list-first lsts))
                      result))))))

(define (list-for-each fn . lsts)
  (unless (null? lsts)
    (do ((lsts lsts (map list-rest lsts)))
      ((memq #t (map list-null? lsts)))
      (apply fn (map list-first lsts)))))

(define (list-filter ok? lst)
  (let loop ((ls lst) (yes (list-null)) (no (list-null)))
    (cases typed-list ls
      (list-null ()
        (values (list-reverse yes) (list-reverse no)))
      (list-cons (first rest)
         (if (ok? first)
           (loop rest (list-cons first yes) no)
           (loop rest yes (list-cons first no)))))))

(define (list-equal? lst0 lst1)
  (let loop ((ls0 lst0) (ls1 lst1))
    (cond
      ((list-null? ls0)
       (list-null? ls1))
      ((list-null? ls1)
       (list-null? ls0))
      (else
        (and (equ? (list-first ls0)
                    (list-first ls1))
             (loop (list-rest ls0)
                   (list-rest ls1)))))))

(define (list-memp ok? lst)
  (let loop ((ls lst))
    (cases typed-list ls
      (list-null () #f)
      (list-cons (first rest)
         (if (ok? first)
           ls
           (loop rest))))))

(define (list-member item lst)
  (list-memp (lambda (x) (equ? x item)) lst))

(define (list-remp ok? lst)
  (call-with-values (lambda () (list-filter ok? lst))
                    (lambda (a b) b)))

(define (list-remove item lst)
  (list-remp (lambda (x) (equ? item x)) lst))

(define (list-adjoin item lst)
  (if (list-member item lst)
    lst
    (list-cons item lst)))

(define (list-remove-dups lst)
  (let loop ((ls lst) (result (list-null)))
    (cases typed-list ls
      (list-null () result)
      (list-cons (first rest)
              (loop rest (list-adjoin first result))))))

(define (list-assp ok? lst)
  (let loop ((ls lst))
    (cases typed-list ls
      (list-null () #f)
      (list-cons (first rest)
        (if (ok? (car first))
          first
          (loop rest))))))

(define (list-assoc item lst)
  (list-assp (lambda (x) (equ? item x)) lst))

(define (list-fold-left op base . lsts)
  (cond
    ((null? lsts) base)
    ((null? (cdr lsts))
     (let loop ((lst (car lsts)) (result base))
       (if (list-null? lst)
         result
         (loop (list-rest lst)
               (op result (list-first lst))))))
    (else
      (let loop ((lsts lsts) (result base))
        (cond
          (((list-of? list-null?) lsts)
           result)
          (((list-of? (o not list-null?)) lsts)
           (loop (map list-rest lsts)
                 (apply op result (map list-first lsts))))
          (else
            (error 'list-fold-left "lists not of equal length")))))))

(define (list-fold-right op base . lsts)
  (cond
    ((null? lsts) base)
    ((null? (cdr lsts))
     (let loop ((lst (list-reverse (car lsts)))
                (result base))
       (if (list-null? lst)
         result
         (loop (list-rest lst)
               (op (list-first lst) result)))))
    (else
      (let loop (
        ;; checking for equal length is done by list-reverse
        (lsts (call-with-values
                (lambda () (apply list-reverse lsts))
                list))
        (result base)
        )
        (if ((list-of? list-null?) lsts)
          result
          (loop (map list-rest lsts)
                (apply op
                       (append (map list-first lsts)
                               (list result)))))))))

(define (list-merge <? lst0 lst1)
  ;; without sorted checks, not tail recursive
  ;(let loop ((ls0 lst0) (ls1 lst1))
  ;  (cond
  ;    ((list-null? ls0) ls1)
  ;    ((list-null? ls1) ls0)
  ;    ((<? (list-first ls0) (list-first ls1))
  ;     (list-cons (list-first ls0)
  ;             (loop (list-rest ls0) ls1)))
  ;    (else
  ;     (list-cons (list-first ls1)
  ;             (loop ls0 (list-rest ls1)))))))
  ;; tail recursive, with sorted checks
  (let loop ((ls0 lst0) (ls1 lst1) (result (list-null)))
    (cond
      ((and (list-null? ls0) (list-null? ls1))
       (list-reverse result))
      ((list-null? ls0)
       (if (or (list-null? (list-rest ls1))
               (<? (list-first ls1) (list-first (list-rest ls1))))
         (loop ls0 (list-rest ls1) (list-cons (list-first ls1) result))
         (error 'list-merge "not sorted" lst1)))
      ((list-null? ls1)
       (if (or (list-null? (list-rest ls0))
               (<? (list-first ls0) (list-first (list-rest ls0))))
         (loop (list-rest ls0) ls1 (list-cons (list-first ls0) result))
         (error 'list-merge "not sorted" lst1)))
      ((not (or (list-null? (list-rest ls0))
                (<? (list-first ls0) (list-first (list-rest ls0)))))
       (error 'list-merge "not sorted" lst0))
      ((not (or (list-null? (list-rest ls1))
                (<? (list-first ls1) (list-first (list-rest ls1)))))
       (error 'list-merge "not sorted" lst1))
      (else
        (if (<? (list-first ls0) (list-first ls1))
          (loop (list-rest ls0) ls1 (list-cons (list-first ls0) result))
          (loop ls0 (list-rest ls1) (list-cons (list-first ls1) result))))
      )))
(define (list-sort <? lst)
  (let loop ((ls lst))
    (let ((len (list-length ls)))
      (if (< len 2)
        ls
        (receive (head tail)
          (list-split-at (quotient len 2) ls)
          (list-merge <?
                   (loop head)
                   (loop tail)))))))
(define (list-sorted? <? lst)
  (let loop ((ls lst))
    (cases typed-list ls
      (list-null () #t)
      (list-cons (first rest)
        (cond
          ((list-null? rest) #t)
          ((<? first (list-first rest))
           (loop rest))
          (else #f))))))

(define (list-zip lst0 lst1)
  (cond
    ((list-null? lst0)
     lst1)
    (else
      (list-cons (list-first lst0)
              (list-zip lst1 (list-rest lst0))))))

(define (list-interpose sep lst)
  (list-rest
    (let loop ((ls lst) (result (list-null)))
      (cases typed-list ls
        (list-null () (list-reverse result))
        (list-cons (first rest)
          (loop rest
                (list-cons first (list-cons sep result))))))))
                ;(list-apply typed-list first sep result)))))))

(define (list-every? ok? lst)
  (not (list-memp (o not ok?) lst)))

(define (list-not-every? ok? lst)
  (if (list-memp (o not ok?) lst) #t #f))

(define (list-not-any? ok? lst)
  (if (list-memp ok? lst)
    #f
    #t))

(define (list-some ok? lst)
  (let loop ((ls lst))
    (cases typed-list ls
      (list-null () #f)
      (list-cons (first rest)
         (if (ok? first)
           first
           (loop rest))))))

(define (list-in? tlst1 tlst2)
  (cases typed-list tlst1
    (list-null () #t)
    (list-cons (first rest)
      (let ((start (list-member first tlst2)))
        (if start
          (let loop ((ls0 tlst1) (ls1 start))
            (cond
              ((and (list-null? ls0) (list-null? ls1)) #t)
              ((list-null? ls0) #t)
              ((list-null? ls1) #f)
              ((equ? (list-first ls0) (list-first ls1))
               (loop (list-rest ls0) (list-rest ls1)))
              (else #f)))
          #f)))))

;;; documentation
(define typed-lists
  (let (
    (signatures '(
      (typed-list? xpr)
      (typed-list . args)
      (untyped-list->typed-list tlst)
      (list-null)
      (list-cons item tlst)
      (list-repeat n x)
      (list-iterate n fn x)
      (list-iterate-while ok? fn x)
      (list-iterate-until ok? fn x)

      (typed-list->untyped-list tlst)
      (list-apply fn . args)
      (list-null? xpr)
      (list-first tlst)
      (list-rest tlst)
      (list-reverse . tlsts)
      (list-length tlst)
      (list-from-upto from upto tlst) ; sublist
      (list-item k tlst) ; ref
      (list-split-at k tlst)
      (list-split-with ok? tlst)
      (list-drop k tlst)
      (list-drop-while ok? tlst)
      (list-take k tlst)
      (list-take-while ok? tlst)
      (list-append . tlsts)
      (list-map fn . tlsts)
      (list-mappend fn . tlsts)
      (list-for-each fn . tlsts)
      (list-filter ok? tlst)
      (list-adjoin item tlst)
      (list-equal? tlst0 tlst1)
      (list-memp ok? tlst)
      (list-member item tlst)
      (list-remp ok? tlst)
      (list-remove item tlst)
      (list-remove-dups tlst)
      (list-assp ok? tlst)
      (list-assoc item tlst)
      (list-fold-left op base . tlsts)
      (list-fold-right op base . tlsts)
      (list-merge <? tlst0 tlst1)
      (list-sort <? tlst)
      (list-sorted? <? tlst)
      (list-zip tlst0 tlst1)
      (list-interpose sep tlst)
      (list-every? ok? tlst)
      (list-some ok? tlst)
      (list-not-every? ok? tlst)
      (list-not-any? ok? tlst)
      (list-in? tlst0 tlst1)
      (list-bind (x ... . xs) tlst xpr . xprs)
      ))
    )
    (case-lambda
      (() (map car signatures))
      ((sym) (assq sym signatures)))))

;;; sets as typed-lists

(define-datatype set set?
  (typed-list->set (ls typed-list?)))

(define (set-add item st)
  (typed-list->set
    (cases set st
      (typed-list->set (ls)
         (list-cons item ls)))))
  
(define (set-remove item st)
  (typed-list->set
    (cases set st
      (typed-list->set (ls)
        (cases typed-list ls
          (list-null ()
            (list-null))
          (list-cons (first rest)
            (if (equ? item first)
              (list-remove item rest)
              (list-cons first
                         (list-remove item rest)))))))))
      
(define (set->typed-list st)
  (cases set st
    (typed-list->set (st) st)))

(define-record-printer (set st out)
  (let ((str (sprintf "~s"
               (typed-list->untyped-list
                 (cases set st
                   (typed-list->set (ls)
                     (list-remove-dups ls)))))))
    (string-set! str 0 #\{)
    (string-set! str (- (string-length str) 1) #\})
    (display str out)))

(define (set . args)
  (typed-list->set (apply typed-list args)))

(define (set-cardinality st)
  (cases set st
    (typed-list->set (ls)
       (list-length (list-remove-dups ls)))))

(define (set-in? item st)
  (cases set st
    (typed-list->set (ls)
      (if (list-member item ls) #t #f))))

(define (set<= set0 set1)
  (cases set set0
    (typed-list->set (ls0)
      (list-every?
        (lambda (item)
          (list-member
            item
            (cases set set1
              (typed-list->set (ls1)
                          ls1))))
        ls0))))

(define (set>= set0 set1) (set<= set1 set0))

(define (set= set0 set1)
  (and (set<= set0 set1)
       (set<= set1 set0)))

;; list-filter not used, to avoid unnessecary reversing
(define (set-filter ok? st)
  (cases set st
    (typed-list->set (ls)
      (let loop ((ls ls) (yes (list-null)) (no (list-null)))
        (cases typed-list ls
          (list-null ()
            (values (typed-list->set yes) (typed-list->set no)))
          (list-cons (first rest)
            (if (ok? first)
              (loop rest (list-cons first yes) no)
              (loop rest yes (list-cons first no)))))))))

(define (set-null? xpr)
  (and (set? xpr)
       (cases set xpr
         (typed-list->set (ls) (list-null? ls)))))

(define (set-difference set0 set1)
  (let loop ((ls1 (set->typed-list  set1))
             (ls0 (set->typed-list set0)))
    (cases typed-list ls1
      (list-null () (typed-list->set ls0))
      (list-cons (first rest)
        (loop rest (list-remove first ls0))))))

;; list-append not used, list-o avoid unnessecary reversing
(define (set-union . sts)
  (cond
    ((null? sts) (typed-list->set (list-null)))
    ((null? (cdr sts)) (car sts))
    ((null? (cddr sts))
     (cases set (car sts)
       (typed-list->set (ls)
         (let loop ((ls ls) (result (cadr sts)))
           (cases typed-list ls
             (list-null () result)
             (list-cons (first rest)
               (loop rest
                     (set-add first result))))))))
    (else
      (set-union (car sts)
                   (apply set-union (cdr sts))))))

(define (set-intersection . sts)
    (cond
      ((null? sts)
       (typed-list->set (list-null)))
      ((null? (cdr sts))
       (car sts))
      ((null? (cddr sts))
       (let ((set1 (cadr sts)))
         (cases set (car sts)
           (typed-list->set (ls)
             (let loop ((ls ls)
                        (result (list-null)))
               (cases typed-list ls
                 (list-null () (typed-list->set result))
                 (list-cons (first rest)
                   (if (set-in? first set1)
                     (loop rest
                           (list-cons first result))
                     (loop rest result)))))))))
      (else
        (set-intersection (car sts)
                            (apply set-intersection (cdr sts))))))

;; documentation procedure
(define sets
  (let (
    (signatures '(
      (set? xpr)
      (set . args)
      (typed-list->set lst)
      (set->typed-list st)
      (set-in? item st)
      (set<= set0 set1)
      (set= set0 set1)
      (set>= set0 set1)
      (set-filter ok? st)
      (set-null? xpr)
      (set-add item st)
      (set-remove item st)
      (set-cardinality st)
      (set-difference set0 set1)
      (set-union . sts)
      (set-intersection . sts)
      ))
    )
    (case-lambda
      (() (map car signatures))
      ((sym) (assq sym signatures)))))

) ; functor typed-lists

;(use simple-tests)
;(import datatype typed-lists)
;;; argument module
;(module nums (type? equ?)
;  (import scheme)
;  (define type? number?)
;  (define equ? =))
;;; apply functor
;(module lists = (typed-lists nums))
;
;(import lists)
;
;(use bindings)
;(seq-length-ref-tail! typed-list?
;                      list-length
;                      (lambda (seq it) (list-item it seq))
;                      (lambda (seq it) (list-drop it seq)))
;(xpr:val (typed-list? (bind (a b . c) (typed-list 1 2 3 4) c)))