333 lines
11 KiB
Scheme
333 lines
11 KiB
Scheme
;;; Copyright (C) Peter McGoron 2024
|
|
;;; This program is free software: you can redistribute it and/or modify
|
|
;;; it under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation, version 3 of the License.
|
|
;;;
|
|
;;; This program is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Code to handle the linked list container.
|
|
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;
|
|
;;; The container is constructed with DL:CTR and has two fields,
|
|
;;; head and tail which point to the start and end of the list.
|
|
|
|
;;; (DL:CTR) constructs an empty doubly linked list container.
|
|
(define dl:ctr
|
|
(lambda () (cons '() '())))
|
|
|
|
(define dl:head car)
|
|
(define dl:set-head! set-car!)
|
|
(define dl:tail cdr)
|
|
(define dl:set-tail! set-cdr!)
|
|
|
|
;;; (DL:EMPTY? CTR) tests if CTR is a list of zero elements.
|
|
(define dl:empty?
|
|
(lambda (ctr)
|
|
(null? (dl:head ctr))))
|
|
|
|
;;; (DL:ADD-FIRST-ELEMENT CTR ELEM) initializes CTR to be a list of one
|
|
;;; element ELEM.
|
|
(define dl:add-first-element
|
|
(lambda (ctr elem)
|
|
(dl:set-head! ctr elem)
|
|
(dl:set-tail! ctr elem)))
|
|
|
|
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Code to handle list elements
|
|
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; List elements are constructed with (DL:ELEM VAL), where VAL is the
|
|
;;; value to be stored in the list.
|
|
|
|
;;; (DL:ELEM VAL) constructs a new doubly linked list element with element
|
|
;;; VAL.
|
|
(define dl:elem
|
|
(lambda (val)
|
|
(vector '() val '())))
|
|
|
|
(define dl:prev
|
|
(lambda (elem) (vector-ref elem 0)))
|
|
(define dl:set-prev!
|
|
(lambda (elem prev) (vector-set! elem 0 prev)))
|
|
|
|
(define dl:val
|
|
(lambda (elem) (vector-ref elem 1)))
|
|
|
|
(define dl:val-equal?
|
|
(lambda (elem x) (equal? (dl:val elem) x)))
|
|
|
|
(define dl:next
|
|
(lambda (elem) (vector-ref elem 2)))
|
|
(define dl:set-next!
|
|
(lambda (elem next) (vector-set! elem 2 next)))
|
|
|
|
(define dl:is-head?
|
|
(lambda (ctr elem)
|
|
(eqv? (dl:head ctr) elem)))
|
|
|
|
(define dl:is-tail?
|
|
(lambda (ctr elem)
|
|
(eqv? (dl:tail ctr) elem)))
|
|
|
|
(define dl:link
|
|
(lambda (before after)
|
|
(dl:set-next! before after)
|
|
(dl:set-prev! after before)))
|
|
|
|
(define dl:unlink
|
|
(lambda (elem)
|
|
(let ((prev (dl:prev elem))
|
|
(next (dl:next elem)))
|
|
(if (not (null? prev))
|
|
(dl:set-next! prev next)
|
|
'())
|
|
(if (not (null? next))
|
|
(dl:set-prev! next prev)
|
|
'())
|
|
(dl:set-prev! elem '())
|
|
(dl:set-next! elem '()))))
|
|
|
|
;;; ;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Linked List operations
|
|
;;; ;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; (DL:PUSH CTR ELEM) pushes ELEM to the head of the list in CTR.
|
|
;;; The element after ELEM is the previous head.
|
|
(define dl:push
|
|
(lambda (ctr elem)
|
|
(if (dl:empty? ctr)
|
|
(dl:add-first-element ctr elem)
|
|
(begin
|
|
(dl:set-prev! elem '())
|
|
(dl:link elem (dl:head ctr))
|
|
(dl:set-head! ctr elem)))))
|
|
|
|
;;; (DL:PUSH-TAIL CTR ELEM) pushes ELEM to the tail of the list in CTR.
|
|
;;; The element before ELEM is the previous tail.
|
|
(define dl:push-tail
|
|
(lambda (ctr elem)
|
|
(if (dl:empty? ctr)
|
|
(dl:add-first-element ctr elem)
|
|
(begin
|
|
(dl:set-next! elem '())
|
|
(dl:link (dl:tail ctr) elem)
|
|
(dl:set-tail! ctr elem)))))
|
|
|
|
;;; (DL:FIND CTR OK?) searches CTR for the first element whose value
|
|
;;; VAL satisfies (OK? VAL). If there is no element, the function
|
|
;;; returns #F.
|
|
(define dl:find
|
|
(lambda (ctr ok?)
|
|
(letrec
|
|
((loop
|
|
(lambda (element)
|
|
(cond
|
|
((null? element) #f)
|
|
((ok? (dl:val element)) element)
|
|
(else (loop (dl:next element)))))))
|
|
(loop (dl:head ctr)))))
|
|
|
|
;;; (DL:FIND-EQUAL CTR VAL) searches CTR for the first element such that
|
|
;;; (EQUAL? CTR (DL:VAL ELEM)). See documentation for DL:FIND
|
|
(define dl:find-equal
|
|
(lambda (ctr val) (dl:find ctr (lambda (x)
|
|
(equal? val x)))))
|
|
|
|
;;; (DL:INSERT-BEFORE CTR ELEM TO-BE-INSERTED)
|
|
;;; places TO-BE-INSERTED in the list before ELEM. ELEM must be a part of
|
|
;;; the list.
|
|
(define dl:insert-before
|
|
(lambda (ctr elem to-be-inserted)
|
|
(if (dl:is-head? ctr elem)
|
|
(dl:push ctr to-be-inserted)
|
|
(let ((prev (dl:prev elem)))
|
|
(dl:link prev to-be-inserted)
|
|
(dl:link to-be-inserted elem)))))
|
|
|
|
;;; (DL:INSERT-AFTER CTR ELEM TO-BE-INSERTED)
|
|
;;; places TO-BE-INSERTED in the list after ELEM. ELEM must be a part of
|
|
;;; the list.
|
|
(define dl:insert-after
|
|
(lambda (ctr elem to-be-inserted)
|
|
(if (dl:is-tail? ctr elem)
|
|
(dl:push-tail ctr to-be-inserted)
|
|
(let ((next (dl:next elem)))
|
|
(dl:link to-be-inserted next)
|
|
(dl:link elem to-be-inserted)))))
|
|
|
|
;;; (DL:REMOVE CTR ELEM) removes ELEM from the list by linking the
|
|
;;; previous and next elements of the list together (if they exist).
|
|
(define dl:remove
|
|
(lambda (ctr elem)
|
|
(let ((was-head? (dl:is-head? ctr elem))
|
|
(was-tail? (dl:is-tail? ctr elem))
|
|
(prev (dl:prev elem))
|
|
(next (dl:next elem)))
|
|
(dl:unlink elem)
|
|
(if was-head?
|
|
(dl:set-head! ctr next)
|
|
#f)
|
|
(if was-tail?
|
|
(dl:set-tail! ctr tail)
|
|
#f))))
|
|
|
|
;;; (DL:PUSH-LIST-BACK CTR LST) appends LST to CTR.
|
|
(define dl:push-list-back
|
|
(lambda (ctr lst)
|
|
(if (null? lst)
|
|
ctr
|
|
(begin
|
|
(dl:push-tail ctr (dl:elem (car lst)))
|
|
(dl:push-list-back ctr (cdr lst))))))
|
|
|
|
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Tests
|
|
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define %dl:equal-to-list?
|
|
(lambda (ctr lst)
|
|
(letrec
|
|
((xor?
|
|
(lambda (x y)
|
|
(if x (not y) y)))
|
|
(loop
|
|
(lambda (dl-elem lst-elem)
|
|
(if (not (dl:val-equal? dl-elem (car lst-elem)))
|
|
#f
|
|
(let ((dl-next (dl:next dl-elem))
|
|
(lst-next (cdr lst-elem)))
|
|
(if (xor? (null? dl-next) (null? lst-next))
|
|
#f
|
|
(if (null? dl-next)
|
|
#t
|
|
(loop dl-next lst-next))))))))
|
|
(loop (dl:head ctr) lst))))
|
|
|
|
(define %dl:find-remove
|
|
(lambda (ctr val)
|
|
(let ((elem (dl:find-equal ctr val)))
|
|
(if elem
|
|
(begin
|
|
(dl:remove ctr elem)
|
|
#t)
|
|
#f))))
|
|
|
|
(define %dl:find-remove-from-list
|
|
(lambda (ctr lst)
|
|
(if (null? lst)
|
|
#t
|
|
(if (not (%dl:find-remove ctr (car lst)))
|
|
#f
|
|
(%dl:find-remove-from-list ctr (cdr lst))))))
|
|
|
|
(define %dl:test-insert-into-list
|
|
(lambda (original-list searched-value value-to-insert
|
|
insert-direction modified-list)
|
|
(let ((ctr (dl:ctr)))
|
|
(dl:push-list-back ctr original-list)
|
|
(let ((searched-elem (dl:find-equal ctr searched-value)))
|
|
(if (not searched-elem)
|
|
#f
|
|
(begin
|
|
(insert-direction ctr
|
|
searched-elem
|
|
(dl:elem value-to-insert))
|
|
(%dl:equal-to-list? ctr modified-list)))))))
|
|
|
|
(define %dl:tests
|
|
(list
|
|
(cons "insert one in front"
|
|
(lambda ()
|
|
(let ((ctr (dl:ctr)))
|
|
(dl:push ctr (dl:elem 5))
|
|
(%dl:equal-to-list? ctr '(5)))))
|
|
(cons "insert one in back"
|
|
(lambda ()
|
|
(let ((ctr (dl:ctr)))
|
|
(dl:push-tail ctr (dl:elem 5))
|
|
(%dl:equal-to-list? ctr '(5)))))
|
|
(cons "insert many"
|
|
(lambda ()
|
|
(let ((ctr (dl:ctr))
|
|
(to-insert '(1 2 3 4 5)))
|
|
(dl:push-list-back ctr to-insert)
|
|
(%dl:equal-to-list? ctr '(1 2 3 4 5)))))
|
|
(cons "insert then delete"
|
|
(lambda ()
|
|
(let ((ctr (dl:ctr))
|
|
(el (dl:elem 5)))
|
|
(dl:push ctr el)
|
|
(dl:remove ctr el)
|
|
(dl:empty? ctr))))
|
|
(cons "insert many then delete all"
|
|
(lambda ()
|
|
(let ((ctr (dl:ctr))
|
|
(vals '(1 2 3 4 5)))
|
|
(dl:push-list-back ctr vals)
|
|
(if (not (%dl:find-remove-from-list ctr vals))
|
|
#f
|
|
(dl:empty? ctr)))))
|
|
(cons "insert many then delete some"
|
|
(lambda ()
|
|
(let ((ctr (dl:ctr)))
|
|
(dl:push-list-back ctr '(1 2 3 4 5 6 7 8 9 10))
|
|
(if (not (%dl:find-remove-from-list ctr '(1 2 5 7 10)))
|
|
#f
|
|
(%dl:equal-to-list? ctr '(3 4 6 8 9))))))
|
|
(cons "push head many"
|
|
(lambda ()
|
|
(let ((ctr (dl:ctr)))
|
|
(dl:push ctr (dl:elem 1))
|
|
(dl:push ctr (dl:elem 2))
|
|
(dl:push ctr (dl:elem 3))
|
|
(%dl:equal-to-list? ctr '(3 2 1)))))
|
|
(cons "insert before in the middle"
|
|
(lambda ()
|
|
(%dl:test-insert-into-list '(1 2 3 4 5)
|
|
3
|
|
10
|
|
dl:insert-before
|
|
'(1 2 10 3 4 5))))
|
|
(cons "insert before at head"
|
|
(lambda ()
|
|
(%dl:test-insert-into-list '(1 2 3 4 5)
|
|
1
|
|
10
|
|
dl:insert-before
|
|
'(10 1 2 3 4 5))))
|
|
(cons "insert before at tail"
|
|
(lambda ()
|
|
(%dl:test-insert-into-list '(1 2 3 4 5)
|
|
5
|
|
10
|
|
dl:insert-before
|
|
'(1 2 3 4 10 5))))
|
|
(cons "insert after in middle"
|
|
(lambda ()
|
|
(%dl:test-insert-into-list '(1 2 3 4 5)
|
|
3
|
|
10
|
|
dl:insert-after
|
|
'(1 2 3 10 4 5))))
|
|
(cons "insert after at head"
|
|
(lambda ()
|
|
(%dl:test-insert-into-list '(1 2 3 4 5)
|
|
1
|
|
10
|
|
dl:insert-after
|
|
'(1 10 2 3 4 5))))
|
|
(cons "insert after at tail"
|
|
(lambda ()
|
|
(%dl:test-insert-into-list '(1 2 3 4 5)
|
|
5
|
|
10
|
|
dl:insert-after
|
|
'(1 2 3 4 5 10))))))
|
|
|