;;; TODO: FIX ME  /soegaard 27 june 2005

; list.ss  --  Jens Axel S?gaard  --  18th may 2003

(include "queue.scm")

;;; SIGNATURES

(define-signature sequence^
  (empty
   empty?
   insert   
   remove   
   first
   fold
   ; fold/exit
   ))

(define-signature list^    
  ((open sequence^)
   ; sequence names
   insert-first
   remove-first
   ; list names
   cons          ; = insert = insert-first
   car           ; = first
   cdr rest      ; = remove-first
   ))

(define-signature random-access-list^
  ((open list^)
   ref ; (lookup in [Oka])   ; int list-of-alpha -> alpha
   set ; (update in [Oka])   ; int alpha list-of-alpha -> list-of-alpha
   ))

(define-signature double-ended-sequence^
  ((open sequence^)
   insert-first
   insert-last   
   remove-first
   remove-last))

(define-signature double-ended-list^    
  ( ; (open list^)
   cons car cdr rest
        
        insert-first
        remove-first
        insert-last
        snoc          ; = insert-last
        ))

;;; Catenable lists
(define-signature catenable-list^    
  ((open list^)
   append
   insert-last
   snoc
   ))

(define-signature catenable-double-ended-list^    
  ((open double-ended-list^)
   append))


(define-syntax use-catenable-list
  (syntax-rules ()
    [(use-catenable-list catenable-list-unit)        
     (namespace-variable-bind/invoke-unit/sig catenable-list^ catenable-list-unit)]
    [(use-catenable-list catenable-list-unit prefix) 
     (namespace-variable-bind/invoke-unit/sig catenable-list^ catenable-list-unit prefix)]))

(define-syntax use-random-access-list
  (syntax-rules ()
    [(_ unit)        
     (namespace-variable-bind/invoke-unit/sig random-access-list^ unit)]
    [(_ unit prefix) 
     (namespace-variable-bind/invoke-unit/sig random-access-list^ unit prefix)]))

;;; BUILTIN LISTS

(define list:cons cons)
(define list:car car)
(define list:cdr cdr)
(define list:foldl fold)

(define builtin-list@
  (unit/sig list^
    (import)
    
    (define empty        '())
    (define empty?       null?)
    
    (define cons         list:cons)
    (define insert-first cons)
    (define insert1      list:cons)
    (define (insert l . xs)
      (foldl xs insert1 l l))
    
    (define car          list:car)
    (define first car)
    
    (define cdr          list:cdr)
    (define remove       cdr)
    (define remove-first cdr)
    (define rest         cdr)
    
    (define fold         list:foldl)))



;;; BOOTSTRAPPED CATENABLE LIST FROM QUEUE

(define (bootstrap-catenable-list queue@)
  (unit/sig catenable-list^
    (import)
    (define-values/invoke-unit/sig queue^ queue@ q)
    
    (define empty '())
    (define-struct catenable-list (elm queue))
    
    (define elm   catenable-list-elm)
    (define queue catenable-list-queue)
    (define make  make-catenable-list)
    
    (define empty? null?)
    
    (define (first xs)
      (elm xs))
    
    (define car first)
    
    (define (append xs ys)
      (cond
        [(null? xs)  ys]
        [(null? ys)  xs]
        [else       (link xs ys)]))
    
    (define (link xs ys)
      (make (elm xs) (q:insert (queue xs) ys)))
    
    (define (cons x xs)
      (append (make x q:empty)
              xs))
    
    (define insert cons)
    (define insert-first cons)
    
    (define (snoc xs x)
      (append xs
              (make x q:empty)))
    
    (define insert-last snoc)
    
    (define (rest xs)
      (if (q:empty? (queue xs))
          empty
          (link-all (queue xs))))
    
    (define cdr rest)
    
    (define remove rest)
    (define remove-first rest)
    
    (define (link-all q)
      (let ([t  (q:first q)]
            [q1 (q:remove q)])
        (if (q:empty? q1)
            t
            (link t (link-all q1)))))
    
    (define (fold)
      (error "fold not implemented"))))


;;; SKEW BINARY RANDOM-ACCESS LISTS

; Reference: [Oka, p.132-134]
; Hint:      These lists are a good choice if you
;            both list-like and array-like operations.

(define skew-binary-random-access-list@
  (unit/sig random-access-list^
    (import)
    (rename (sb:cons         cons)
            (sb:car          car)
            (sb:cdr          cdr)
            (sb:insert-first insert-first))
    
    
    (define empty '())               ; a tree is either leaf or node
    (define-struct leaf (e))
    (define-struct node (e l r))     ; e element, l and r trees
    (define-struct root (w t))       ; w integer, t tree
    
    (define list:cons cons)
    (define (insert1 x rs)
      (if (and (not (null? rs))
               (not (null? (cdr rs))))
          (let* ([r1  (list:car rs)]
                 [w1  (root-w r1)]
                 [t1  (root-t r1)]
                 
                 [r2  (list:car (list:cdr rs))]
                 [w2  (root-w r2)]
                 [t2  (root-t r2)])      
            (if (= w1 w2)
                (list:cons (make-root (+ 1 w1 w2) 
                                      (make-node x t1 t2))
                           (cddr rs))
                (list:cons (make-root 1 (make-leaf x))
                           rs)))
          (list:cons (make-root 1 (make-leaf x)) rs)))
    
    (define sb:cons insert1)
    (define sb:insert-first insert1)
    
    (define (insert l . xs)
      (let loop ([l l]
                 [xs xs])
        (if (null? xs)
            l
            (loop (insert1 (list:car xs) l)
                  (list:cdr xs)))))
    
    (define (first rs)
      (if (and (= (root-w (list:car rs)) 1)
               (leaf? (root-t (list:car rs))))
          (leaf-e (root-t (list:car rs)))
          (node-e (root-t (list:car rs)))))
    (define sb:car first)
    
    (define (rest rs)
      (if (null? rs) (error))
      (if (and (= (root-w (list:car rs)) 1) 
               (leaf? (root-t (list:car rs))))
          (list:cdr rs)
          (list:cons (make-root (quotient (root-w (list:car rs)) 2)
                                (node-l (root-t (list:car rs))))
                     (list:cons (make-root (quotient (root-w (list:car rs)) 2)
                                           (node-r (root-t (list:car rs))))
                                (list:cdr rs)))))
    (define sb:cdr rest)
    
    (define remove rest)
    (define remove-first rest)
    
    (define (ref rs i)
      (if (null? rs)
          (error "ref: index " i "too large."))
      (let ([w (root-w (list:car rs))])
        (if (< i w)
            (ref-tree w i (root-t (list:car rs)))
            (ref (list:cdr rs) (- i w)))))
    
    (define (ref-tree w i t)
      (cond
        [(and (= w 1) (= i 0) (leaf? t))  (leaf-e t)]
        [(and         (= i 0) (node? t))  (node-e t)]
        [else (if (<= i (quotient w 2))
                  (ref-tree (quotient w 2) (sub1 i) (node-l t))
                  (ref-tree (quotient w 2) (- (sub1 i) (quotient w 2)) (node-r t)))]))
    
    (define (set rs i y)
      (let ([w (root-w (list:car rs))])
        (if (< i w)
            (list:cons (make-root w (set-tree w i (root-t (list:car rs)) y))
                       (list:cdr rs))
            (list:cons (list:car rs)
                       (set (list:cdr rs) (- i w) y)))))
    
    
    (define (set-tree w i t y)
      (cond
        [(and (= w 1) (= i 0) (leaf? t))  (make-leaf y)]
        [(and         (= i 0) (node? t))  (make-node y (node-l t) (node-r t))]
        [else (if (<= i (quotient w 2))
                  (make-node (node-e t)
                             (set-tree (quotient w 2) (sub1 i) (node-l t) y)
                             (node-r t))
                  (make-node (node-e t)
                             (node-l t)
                             (set-tree (quotient w 2) (- (sub1 i) (quotient w 2)) (node-r t) y)))]))
    
    (define (fold f b l)
      (if (empty? l)
          b
          (fold f (f (first l) b) (rest l))))
    
    ;    (define empty '())
    (define empty? null?)
    
    (define (collect l)
      (fold list:cons '() l))))
