;;; 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))))