;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL -*-

(define-standard-structure
  continuation
   previous-continuation
   fctn
   machine-state)
  
(define-standard-structure
  history-subproblem
   valid-flag
   previous-subproblem
   next-subproblem
   reductions)

(define-standard-structure
  history-reduction
   valid-flag
   previous-reduction
   next-reduction
   continuation)

(define-standard-structure
  history
   current-subproblem
   current-reduction)

(defun create-double-linked-structures (size maker linker)
  (let ((elements '()))
    (dotimes (count size)
      (push (funcall maker) elements))
    (do ((count 0 (1+ count))
	 (skeleton (apply #'circular-list elements) (rest skeleton)))
	((= count size) elements)
      (let ((this-element (first  skeleton))
	    (next-element (second skeleton)))
	(funcall linker this-element next-element)))))

(defun create-reduction-ring (size)
  (create-double-linked-structures
    size
    #'(lambda ()
	(make-history-reduction
	  :valid-flag nil
	  :previous-reduction   nil
	  :next-reduction       nil
	  :continuation         nil))
    #'(lambda (this-reduction next-reduction)
	(setf (history-reduction-next-reduction     this-reduction) next-reduction)
	      (history-reduction-previous-reduction next-reduction) this-reduction)))

(defun create-subproblem-ring (size reduction-ring-size)
  (create-double-linked-structures
    size
    #'(lambda ()
	(make-history-subproblem
	  :valid-flag nil
	  :previous-subproblem   nil
	  :next-subproblem       nil
	  :reductions            (first (create-reduction-ring reduction-ring-size))))
    #'(lambda (this-subproblem next-subproblem)
	(setf (history-subproblem-next-subproblem     this-subproblem) next-subproblem
	      (history-subproblem-previous-subproblem next-subproblem) this-subproblem))))

(defun create-history (subproblems reductions)
  (let ((s-ring (create-subproblem-ring subproblems reductions)))
    (make-history
      :current-subproblem (first s-ring)
      :current-reduction  (history-subproblem-reductions (first s-ring)))))

(defun spread-history (history receiver)
  (funcall receiver
	   (history-current-subproblem history)
	   (history-current-reduction history)))

(defun rotate-reduction-ring (direction history)
  (let ((next-reduction
	  (funcall direction
	    (history-current-reduction history))))
    (setf (history-current-reduction history) next-reduction)
    next-reduction))

(defun rotate-subproblem-ring (direction history)
  (spread-history history
    #'(lambda (current-subproblem current-reduction)
	(setf (history-subproblem-reductions current-subproblem) current-reduction)
	(let ((next-subproblem (funcall direction current-subproblem)))
	  (setf (history-current-subproblem history) next-subproblem
		(history-current-reduction  history) (history-subproblem-reductions next-subproblem))
	  next-subproblem))))

(defvar *maximum-subproblems-to-record* 10.)
(defvar *maximum-reductions-to-record*   5.)

(defvar *history*)

(defun print-cont-result (values)
  (inspect values)
  (format t "~%Returning to LISP~% ~S" values))

(defun startup (fctn arglist)
  (setq *history* (create-history *maximum-subproblems-to-record*
				  *maximum-reductions-to-record*))
  (top-level-continuation-driver
    fctn
    (make-continuation
      :previous-continuation ()
      :fctn                  #'print-cont-result
      :machine-state         ())
    arglist))

(defun top-level-continuation-driver (initial-fctn initial-continuation initial-state)
  (do ((fctn         initial-fctn)
       (continuation initial-continuation)
       (state        initial-state))
      ((null continuation) (apply fctn state))
    (let ((next-continuation
	    (catch 'continue
	      (apply fctn continuation state))))
; Debugging
;      (format t "~%Received ~S ~S ~S"
;	      (continuation-fctn                  next-continuation)
;	      (continuation-machine-state         next-continuation)
;	      (continuation-previous-continuation next-continuation))
      (setq fctn         (continuation-fctn                  next-continuation)
	    continuation (continuation-previous-continuation next-continuation)
            state        (continuation-machine-state         next-continuation)))))

(defun do-reduction (fctn continuation arglist)
  (let ((reduction-continuation
	  (make-continuation
	    :previous-continuation continuation
	    :fctn                  fctn
	    :machine-state         arglist)))
    (let ((reduction (rotate-reduction-ring #'history-reduction-next-reduction *history*)))
      (setf (history-reduction-continuation reduction) reduction-continuation
	    (history-reduction-valid-flag   reduction) t))
    (throw 'continue reduction-continuation)))

(defun do-subproblem (subproblem-fctn subproblem-args
		      current-continuation
		      return-fctn return-args)
  (let ((return-continuation (make-continuation
			       :previous-continuation current-continuation
			       :fctn                  return-fctn
			       :machine-state         return-args))
	(next-subproblem (rotate-subproblem-ring #'history-subproblem-next-subproblem *history*)))
    (setf (history-subproblem-valid-flag next-subproblem) t
	  (history-reduction-valid-flag (history-subproblem-reductions next-subproblem)) nil)
    (do-reduction subproblem-fctn return-continuation subproblem-args)))

(defun do-return (continuation return-value)
  (setf (continuation-machine-state continuation)
	   (cons return-value (continuation-machine-state continuation))
	(history-subproblem-valid-flag (history-current-subproblem *history*)) nil)
  (rotate-subproblem-ring #'history-subproblem-previous-subproblem *history*)
  (throw 'continue continuation))