;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

(use goo/boot)
(use goo/fun)
(use goo/class)
(use goo/macros)
(use goo/types)
(use goo/any)
(use goo/log)
(use goo/chr)
(use goo/mag)
(use goo/math)
(use goo/cols/col)
(use goo/cols/colx)
(use goo/cols/seq)
(use goo/cols/seqx)

;; 3.7.5 LISTS

;;;;!! Interface

(exported
 ;; defined in boot
 <lst> head head-setter tail tail-setter nil
 ;; Alias for <lst>
 (dv <list> <lst>)
 (dg lst (elts|... => <lst>))
 (dg lst* (elts|... => <lst>))
 
 ;; Alias for list
 (dv list lst)

 (dg pair (x|<any> y|<lst> => <lst>))

;; undocumented
 (dg assqn (x l|<lst> pos|<int> => <any>))
 (dg assq (x l|<lst> => <any>))
 def-list
)

;;;;!! Implementation

;;;; Collection protocol
(dm len (x|<lst> => <int>)
  (rep sum (((count <int>) 0) ((x <lst>) x))
    (if (nul? x) count (sum (+ count 1) (tail x)))))

(dm elt-or (x|<lst> key|<int> default => <any>)
  (rep fnd (((count <int>) 0) ((x <lst>) x))
    (if (nul? x)
        default
        (if (== count key)
            (head x)
            (fnd (+ count 1) (tail x))))))

(dm elt-setter (z x|<lst> key|<int>)
  (rep fnd (((count <int>) 0) ((x <lst>) x))
    (if (nul? x)
        (range-error x key)
        (if (== count key)
            (set (head x) z)
            (fnd (+ count 1) (tail x))))))

(dm (nul? inline) (c|<lst> => <log>) (== c (nul (class-of c))))

(dm (nul inline) ((c (t= <lst>)) => <lst>) '())

(dm fab ((t (t< <lst>)) s|<int> => <lst>)
  (rep fab ((i|<int> s) (res|<lst> (nul t)))
    (if (> i 0)
        (fab (- i 1) (new t tail res))
        res)))

(dm fabs ((c (t< <lst>)) objects|... => <lst>)
  (rep build ((index|<int> (- (len objects) 1)) (result|<lst> (nul c)))
    (if (< index 0)
        result
        (build (- index 1) 
               (new c head (elt objects index) tail result)))))

(dm lst* (args|... => <lst>)
  (def m (1- (len args)))
  (rep cons ((i|<int> (1- m)) (r|<lst> [args m]))
    (if (< i 0)
        r
        (cons (1- i) (new <lst> head [args i] tail r)))))

;;;; Iteration protocol for lists
(dc <lst-enum> (<enum>))
(dp! %dat (<lst-enum> => <lst>))
(dp! %key (<lst-enum> => <int>) 0)
(dm enum (x|<lst> => <lst-enum>)
  (new <lst-enum> %dat x))
(dm fin? (e|<lst-enum> => <log>)
  (nul? (%dat e)))
(dm nxt (e|<lst-enum> => <lst-enum>)    
  (renew e %key (+ (%key e) 1) %dat (tail (%dat e))))
(dm now (e|<lst-enum> => <any>)
  (head (%dat e)))
(dm now-setter (v|<any> e|<lst-enum>)
  (set (head (%dat e)) v))
(dm now-key (e|<lst-enum> => <int>)
  (%key e))

;;;; Sequence protocol
(dm add (c|<lst> x => <lst>)
  (pair x c))

(dm last (x|<lst> => <any>)
  (rep fnd ((x x) (px x))
    (if (nul? x) (head px) (fnd (tail x) x))))

(dm rev! (c|<lst> => <lst>)
  (rep loop ((l c) (r (nul (class-of c))))
    (if (nul? l)
        r
        (let ((t (tail l)))
          (set (tail l) r)
          (loop t l)))))

(dm cat! (x|<lst> more|... => <lst>)
  (loc ((connect (x|<lst> y|<lst> => <lst>)
          ;; connect x to y and return the last elem of the list
          (if (nul? y)
              x
              (seq (set (tail x) y)
                   (rep find-tail ((p|<lst> y))
                     (if (nul? (tail p))
                         p
                         (find-tail (tail p))))))))
    (def result (lst #f))
    (def cur result) ;; TODO: MERGE WITH NEXT LINE?
    (set cur (connect cur (as <lst> x)))
    (for ((x more))
      (set cur (connect cur (as <lst> x))))
    (tail result)))

;;;; List protocol
(dm lst (objects|... => <lst>)
  (app fabs <lst> objects))

(dm pair (h t|<lst> => <lst>)
  (new <lst> head h tail t))

(dm push! (c|<lst> x => <lst>)
  (pair x c))

(dm pop! (c|<lst> => (tup new-c|<lst> value|<any>))
  (tup (tail c) (head c)))

;;; TODO: BUBBLE SORT YUCK!
(dm sort-by! (items|<lst> test|<fun> => <lst>)
  (rep loop ((tmp #f))
    (if (== tmp (head items))
        items
        (rep bub ((tmp (head items)) (prev items) (next (tail items)))
          (if (nul? next)
              (loop tmp)
              (bub (if (test (head next) (head prev))
                       (let ((tmp (head prev)))
                         (set (head prev) (head next))
                         (set (head next) tmp))
                       tmp)
                   (tail prev) (tail next)))))))

;;;; Misc other stuff
(dm to-str (x|<lst> => <str>)
  (cat "(" (vals-to-str x) ")"))



;;;; Not documented
;; TODO: CHANGE ORDER OF ARGS LIKE MEM?
(dm assq (x l|<lst> => <any>)
  (if (nul? l)
      #f
      (if (== x (head (head l)))
          (head l)
          (assq x (tail l)))))

(dm assqn (x l|<lst> pos|<int> => <any>)
  (if (nul? l)
      #f
      (if (== x (elt (head l) pos))
          (head l)
          (assqn x (tail l) pos))))

;; (ct (dv cat-sym make-sym))
(ds def-list (,name (,@supers))
  (let ((class  (cat-sym "<" name ">"))
        ($nul (cat-sym "$" name "-nul")))
    `(seq (dc ,class (<lst> ,@supers))
          (dv ,$nul (new ,class))
          (df ,name (h t) (new ,class head h tail t))
          (dm nul ((e (t= ,class)) => ,class) ,$nul))))

(dm line-of (x) #f)

(dc <line> (<mag>))
  (dp line-of (<line> => (t? <int>)) #f)

(def-list line-pah (<line>))

(dv <line-list> <line-pah>)

(df line-pair (h t l) (new <line-list> head h tail t line-of l))

(df line-list (l elts|...) 
  (rep fab ((r (nul <line-list>)) (i (- (len elts) 1)))
    (if (< i 0)
        r
        (fab (line-pair (elt elts i) r l) (- i 1)))))

(dm line-list-of (ctx|<lst> src|<lst> => <lst>)
  (rep copy ((l (line-of ctx)) (src src))
    (if (and (isa? src <lst>) (not (nul? src)))
        (let ((h (head src)) (t (tail src)))
          (line-pair (copy (or (line-of h) l) h) (copy (or (line-of t) l) t) l))
        src)))

(dm line-list-of (ctx src => <any>) src)

(export <line> line-of <line-list> line-pair line-list line-list-of)

