Doubly Linked Lists

#lang racket

(provide empty-dlink dlink? view-dlink -> <- dl-cons )

(struct node (l k r) #:transparent)
(struct head (n))
(struct tail (n))

;; An empty dlink, initialized to point at the tail
(define empty-dlink
  (tail (head #f)))

(define (dlink? p)

  ;; This helper traverses in the direction dir and ensures that the tree is left/right linear, and null terminated correctly.
  (define (linear? n [dir node-l])


    (let {;; empty-dir is the direction opposite to dir. It should be empty, if this is a correct dlinked list.
          [empty-dir (cadr (member dir `(,node-l ,node-r ,node-l)))]

          ;; This is the corresponding null terminator for the dir.
          [null-ptr? (cadr (member dir (list node-l (conjoin head? (negate head-n))
                                             node-r (conjoin tail? (negate tail-n)))))]}

      ;; Either this node is a null terminator, or there's more to traverse
      (or (null-ptr? n)
          (and (node? n)
               (empty? (empty-dir n))
               (linear? (dir n) dir)))))

  ;; The cases
  (or (and (node? p)
           (linear? (node-l p) node-l)
           (linear? (node-r p) node-r))
      (and (head? p)
           (linear? (head-n p) node-r))
      (and (tail? p)
           (linear? (tail-n p) node-l))))

(define (view-dlink p)
  ;; This helper traverses in the direction dir and ensures that the tree is left/right linear, and null terminated correctly.
  (define (linear n [dir node-l])


    (let {;; empty-dir is the direction opposite to dir. It should be empty, if this is a correct dlinked list.
          [empty-dir (cadr (member dir `(,node-l ,node-r ,node-l)))]

          ;; This is the corresponding null terminator for the dir.
          [null-ptr? (cadr (member dir (list node-l (conjoin head? (negate head-n))
                                             node-r (conjoin tail? (negate tail-n)))))]}

      ;; Either this node is a null terminator, or there's more to traverse
      (cond
        [(null-ptr? n) `(,n)]
        [(and (node? n) (empty? (empty-dir n))) (cons (node-k n) (linear (dir n) dir))]
        [else (printf "got ~a, ~a\n" n dir)])))
  (match p
    [(head n) `(head ,(linear n node-r))]
    [(tail n) `(,(reverse (linear n node-l)) tail)]
    [(node l k r) `(,(reverse (linear l node-l)) (root ,k) ,(linear r node-r))]))

(define (-> n)
  (match n
    ;; rotate the head
    [(head (tail #f))      (tail (head #f))]
    [(head (node '() k r)) (node (head #f) k r)]

    ;; if the right is a tail, return the tail
    [(node l k (tail #f)) (tail (node l k '()))]

    ;; else, do some rotating
    [(node l b (node '() c r)) (node (node l b '()) c r)]))

(define (<- n)
  (match n
    ;; rotate the tail
    [(tail (head #f))          (head (tail #f))]
    [(tail (node l k '())) (node l k (tail #f))]

    ;; if the left is a head, return the head
    [(node (head #f) k r) (head (node '() k r))]

    ;; else, do some rotating
    [(node (node l a '()) b r) (node l a (node '() b r))]))

;; Adds a node in front of the current node, also moves the pointer (so it feels a lot like the built-in cons)
(define (dl-cons e dl)
  (match dl
    [(tail n) (node n e (tail #f))]
    [(node l k r) (node l e (node '() k r))]))