;D - D is a doubly-linked list package, providing routines inspired by those traditional CONS cells.
;Copyright (C) 2020 Prince Trippy <programmer@verisimilitudes.net>.

;This program is free software: you can redistribute it and/or modify it under the terms of the
;GNU Affero General Public License version 3 as published by the Free Software Foundation.

;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 Affero General Public License for more details.

;You should have received a copy of the GNU Affero General Public License along with this program.
;If not, see <http://www.gnu.org/licenses/>.

(cl:defpackage #:d (:use #:common-lisp) ;SHADOWing is done, later.  I'm not writing all 234 symbols.
  (:shadow . #0=(#:cons #:consp #:link #:unlink #:cbr #:car #:cdr #:nthcbr #:nthcdr
                 #:list #:list* #:listp #:make-list #:length #:list-length #:pop #:push
                 ;#:properp
                 ))
  (:export . #0#)
  (:documentation "The D provides for manipulating doubly-linked lists, mimicking singly-linked."))

(cl:in-package #:d)

(deftype traversal () '(member cbr cdr))

(defclass cons () ((cbr :accessor cbr :initarg cbr :documentation "This is the backwards link.")
                   (car :accessor car :initarg car :documentation "This links to the contents.")
                   (cdr :accessor cdr :initarg cdr :documentation "This is the downwards link."))
  (:documentation "A doubly-linked list can be traversed backwards.") ;I may not need such defaults.
  (:default-initargs cbr nil car nil cdr nil))

(defmethod cbr ((cons (eql nil))) (declare (ignore cons)) nil) ;It's not worth writing a macro here.
(defmethod car ((cons (eql nil))) (declare (ignore cons)) nil) ;Still, this is a nice, little trick.
(defmethod cdr ((cons (eql nil))) (declare (ignore cons)) nil)

#.`(progn ,@(let (list) ;The following code generates the CNNR, CNNNR, and CNNNNR functions at READ.
              (dolist (first #0='(cbr car cdr) list)
                (flet ((*** (&rest symbols) ;This shadows, interns, and exports the generated names.
                         (let ((string (format nil "~A~*~{~A~}~1@*~A" '#:c '#:r ;This is reordering.
                                               (mapcar (lambda (symbol)
                                                         (char (symbol-name symbol) 1))
                                                       symbols))))
                           (shadow string)
                           (export (intern string))
                           (intern string))))
                  (dolist (second #0#)
                    (let ((symbol (*** first second)))
                      (cl:push `(defun ,symbol (cons) (,first (,second cons))) list)
                      (cl:push `(defsetf ,symbol (cons) (elt) ;These DEFSETF were a bother to write.
                                  (cl:list 'setf (cl:list ',first (cl:list ',second cons))
                                           elt))
                               list))
                    (dolist (third #0#)
                      (let ((symbol (*** first second third)))
                        (cl:push `(defun ,symbol (cons) (,first (,second (,third cons)))) list)
                        (cl:push `(defsetf ,symbol (cons) (elt)
                                    (cl:list 'setf (cl:list ',first
                                                            (cl:list ',second
                                                                     (cl:list ',third cons)))
                                             elt))
                                 list))
                      (dolist (fourth #0#)
                        (let ((symbol (*** first second third fourth)))
                          (cl:push `(defun ,symbol (cons)
                                      (,first (,second (,third (,fourth cons)))))
                                   list)
                          (cl:push `(defsetf ,symbol (cons) (elt)
                                      (cl:list 'setf
                                               (cl:list ',first
                                                        (cl:list ',second
                                                                 (cl:list ',third
                                                                          (cl:list ',fourth cons))))
                                               elt))
                                   list)))))))))

(defun cons (cbr car cdr)
  "Create one node of a doubly-linked list, containing the three links specified.
Importantly, this doesn't link any other nodes of the list; see LINK for this."
  (make-instance 'cons 'cbr cbr 'car car 'cdr cdr))

(defun link (cbr cdr) "Link together the CBR and CDR of a doubly-linked list, returning both."
  (setf (cbr cdr) cbr (cdr cbr) cdr) ;This rightfully signals an error in case either be not a CONS.
  (values cbr cdr))

(defun unlink (cons) "Remove a node from a doubly-linked list, adjusting all relevant links."
  (cond ((and (cbr cons) (cdr cons)) (link (cbr cons) (cdr cons)) ;I'm not satisfied with my design.
         (setf (cbr cons) nil (cdr cons) nil)) ;LINKing maintains the list, but this also haunts me.
        ((cbr cons) (setf (cdbr cons) nil (cbr cons) nil)) ;Though these edge cases wouldn't change.
        ((cdr cons) (setf (cbdr cons) nil (cdr cons) nil)))
  cons)

;I stumbled upon the idea for this primitive, noticing the tortoise and hare algorithm was unneeded.
;A doubly-linked list can be checked for circularity much more easily, due to the backwards linking.
;A more useful primitive is warranted at such a point, as there's little reason to avoid doing this.
;Originally, it would call upon every full node, but this isn't much useful, and could cause errors.
(defun properp (cons &optional (every 'identity) (by nil both) &aux (both (not both)))
  "This predicate returns T if the CONS designates a doubly-linked list of valid links, or else NIL.
If a second argument be provided, it must be a function designator, and is called upon every CAR.
This function is for side-effects and must beware it may stop being called upon an improper list.
The final parameter permits discriminating the list, in the case when it be either of CBR or CDR.
See LENGTH and LIST-LENGTH for other functions which similarly allow discriminating the lists so.
Unfortunately, deciding on but one side of the list to traverse requires passing in the function.
Thus, only to make this more convenient, the function may be passed as NIL."
  (or (consp cons) (return-from properp))
  (or both (check-type by traversal))
  (or every (setq every 'identity))
  (flet ((traversal (first second)
           (prog ((elt cons)) :start
                 (if (null elt) (return))
                 (or (consp elt) (return-from properp))
                 (let ((cons (funcall second elt)))
                   (cond ((not (consp cons)) (return-from properp))
                         ((eq elt (funcall first cons)) (return-from properp))
                         ((null second) (return-from properp))))
                 (funcall every (car elt))
                 (setf elt (funcall first elt))
                 (if (eq cons elt) (return-from properp))
                 (go :start))))
    (cond (both #0=(traversal 'cbr 'cdr) #1=(traversal 'cdr 'cbr))
          ((eq by 'cbr) #0#)
          ((eq by 'cdr) #1#)))
  t)

(defun consp (cons) "This predicate returns T if its argument is a doubly-linked list, else NIL."
  (eq 'cons (type-of cons)))

(defun listp (cons) "This predicate returns T if its argument is NIL or if CONSP would, else NIL."
  (or (null cons) (consp cons)))

;(defmethod print-object ((cons cons) stream &aux (*standard-output* stream))
;  "Print a doubly-linked list to STREAM.  This is currently unREADable and ignores PRINT variables.
;This will be changed later."
;  (print-unreadable-object (cons stream :type 'cons :identity cons)
;    (print-object (car cons) stream)
;    (write-char #\Space)
;    (let ((cons (cbr cons)) (symbol 'cbr))
;      . #0=((format t "~A: " symbol)
;            (typecase cons
;              (cl:cons (cond ((list-length cons symbol) ;This travels, yet I still print in reverse.
;                              (write-char #\()
;                              (loop :for elt := cons :then (funcall symbol elt) :while elt
;                                    :do ())
;                              (write-char #\)))
;                             (t (write-string "CIRCULAR"))))
;              (cons (format t "CL:LIST:~A" cons))
;              (t (format t "Improper:~A" cons)))))
;    (let ((cons (cdr cons)) (symbol 'cdr)) . #0#)
;    
;    (cond ((and (null (cbr cons)) (null (cdr cons)))
;           (format t "(~A)" (car cons)))
;          ((and (not (consp (cbr cons))) (not (consp (cdr cons))))
;           (format t "(~A . ~A . ~A)" (cbr cons) (car cons) (cdr cons)))
;          (t (prog ((cons (loop :for elt := cons :then (cbr elt)
;                             :while (consp (cbr elt)) :finally (return elt))))
;                (write-char #\()
;                (cond ((cbr cons) (prin1 (cbr cons) stream) (write-string " . ")))
;                car (prin1 (car cons) stream)
;                (cond ((consp (cdr cons)) (write-char #\Space) (setf cons (cdr cons)) (go car))
;                      ((cdr cons) (write-string " . ") (prin1 (cdr cons) stream)))
;                (write-char #\))))))
;  cons)

(defun list (&rest values)
  "Create a new doubly-linked list containing the elements specified.
The first value is the front of the list, and the second the back."
  (if values (prog* ((first (cons nil (cl:first values) nil)) (last first)) :start
                    (or (setq values (cl:cdr values))
                        (return-from list (values first last))) ;This was written, before that LINK.
                    (setf (cdr last) (cons last (cl:first values) nil) last (cdr last))
                    (go :start))))

;The following technique is used here: A B C D; A B (C .. E D); A B (C .. E . D); (A . B C .. E . D)
;The same basic explanation holds in cases where VALUES, D, be one element, but in that case C be E.
(defun list* (first second third &rest values &aux last)
  "Behave as LIST, but the first and last elements are the CBR and CDR of the first and last nodes."
  (or values (return-from list* (let ((cons (cons first second third))) (values cons cons))))
  (multiple-value-bind (car end) (apply 'list third values) ;This method avoids unnecessary CONSing.
    (setf last (cbr end) (cdbr end) (car end) (cbr end) first (car end) second)
    (link end car)
    (values end last)))

(defun make-list (length &optional elt)
  "Create a doubly-linked list of a specified length, with each CAR holding the specified element.
This avoids using keyword arguments, by personal preference; the return values are as for LIST."
  (check-type length unsigned-byte "a non-negative integer")
  (if (not (zerop length))
      (prog* ((first (cons nil elt nil)) (last first)) :start
             (if (zerop (decf length))
                 (return-from make-list (values first last)))
             (setf (cdr last) (cons last elt nil) last (cdr last))
             (go :start))))

(progn (defun length (list &optional (by nil both) &aux (both (if both nil t)))
         "Return the length of the doubly-linked list provided as the primary value.
The other two values are the lengths by the CBR and the CDR, respectively.
If only one of these lengths be desired, also pass in the relevant symbol.
An elided CBR or CDR will currently be reported as length zero, if elided."
         (or both (check-type by traversal))
         (flet ((length (list by)
                  (loop :for elt := (funcall by list) :then (funcall by elt) :while elt :sum 1)))
           (let #0=((cbr (if (or both (eq by 'cbr)) (length list 'cbr) 0))
                    (cdr (if (or both (eq by 'cdr)) (length list 'cdr) 0)))
                (values (+ (if (and both list) 1 0) cbr cdr) cbr cdr))))
       (defun list-length (list &optional (by nil both) &aux (both (if both nil t)))
         "This function behaves as LENGTH, primarily returning NIL if the chosen path be circular."
         (or both (check-type by traversal))
         (flet ((length (list by) ;This could be made more efficient, in checking for NIL by second.
                  (loop :for first := (funcall by list) :then (funcall by first)
                        :for second := (funcall by first) :then (funcall by (funcall by second))
                        :if (and first (eq first second)) :do (return)
                        :while first :sum 1)))
           (let #0# (values (cond (both (and cbr cdr (+ (if list 1 0) cbr cdr)))
                                  ((eq by 'cbr) cbr)
                                  ((eq by 'cdr) cdr))
                            cbr cdr)))))

(defun pop (list) "Return the removed car from the list, having unlinked it from the remainder."
  (car (unlink list)))

(defun push (cbr car cdr) "Insert a new CONS into the list, linking it to the others, returning it."
  (nth-value 0 (link (nth-value 1 (link cbr (cons cbr car cdr))) cdr)))

(defun nthcbr (count list) "Return the result of recursively applying CBR count times on the list."
  (dotimes (ignore count list) (declare (ignorable ignore)) (setf list (cbr list))))

(defun nthcdr (count list) "Return the result of recursively applying CDR count times on the list."
  (dotimes (ignore count list) (declare (ignorable ignore)) (setf list (cdr list))))

;(defun position (list &optional (by 'both))
;  ""
;  )
;

;copy-tree sublis nsublis subst * copy-list tree-equal endp nconc append revappend nreconc
;butlast * ldiff tailp member * map * intersection * adjoin pushnew
;set-difference * set-exclusive-or * subsetp union *

;fill subseq reduce count * reverse nreverse sort stable-sort find * search mismatch
;replace substitute * concatenate merge remove * remove-duplicates *
.