UNSLISP/doubly-linked-list.scm

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