;;;; stack.scm -*- Scheme -*-
;;;; Kon Lovett, Sep '21
;;;; Kon Lovett, May '17
;;;; Kon Lovett, Mar '09

;;;; Stack data structure (LIFO queue) where the value is mutable,
;;;; rather than usual pattern of the variable.

;; Issues
;;
;; - DO NOT remove use of fixnum routines. Significant increase in binary size.
;;

(declare
  (bound-to-procedure ##sys#signal-hook))

(module stack

(;export
  make-stack
  list->stack
  stack->list
  stack? check-stack error-stack
  stack-empty?
  stack-count
  stack-peek
  stack-empty!
  stack-poke!
  stack-push!
  stack-cut!
  stack-pop!
  stack-fold
  stack-map
  stack-for-each
  stack-literal-form)

(import scheme
  (chicken base)
  (chicken fixnum)
  (chicken type)
  (only (chicken port) with-output-to-port)
  (only (chicken format) format)
  (srfi 10)
  (only record-variants define-record-type-variant)
  (only (check-errors sys) check-list check-fixnum)
  (only (check-errors basic) define-check+error-type))

;(define-type stack (struct stack#stack))
(define-type stack (struct stack))

(: make-stack (-> stack))
(: list->stack (list -> stack))
(: stack? (* -> boolean : stack))
(: stack-empty? (stack -> boolean))
(: stack-count (stack -> fixnum))
(: stack-peek (stack #!optional fixnum -> *))
(: stack-empty! (stack -> void))
(: stack-poke! (stack * #!optional fixnum -> void))
(: stack-push! (stack #!rest * -> void))
(: stack-cut! (stack fixnum #!optional fixnum -> list))
(: stack-pop! (stack -> *))
(: stack->list (stack -> list))
(: stack-fold (stack procedure * -> *))
(: stack-map (stack procedure -> list))
(: stack-for-each (stack procedure -> void))
(: stack-literal-form (#!optional symbol -> symbol))

;;

(cond-expand
  ((or chicken-5.0 chicken-5.1)
    (define (set-record-printer! tag proc)
      (##sys#register-record-printer tag proc) ) )
  (else) )

;;;

(define-inline (fxzero? x) (fx= 0 x))
(define-inline (fxadd1 x) (fx+ x 1))
(define-inline (fxsub1 x) (fx- x 1))

(define-inline (fxclosed-left? l x h) (and (fx<= l x) (fx< x h)))

(define-inline (list-pair-ref ls0 i0)
  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
  (let loop ((ls ls0) (i i0))
    (cond ((null? ls)
            '() )
          ((fxzero? i)
            ls )
          (else
            (loop (cdr ls) (fxsub1 i)) ) ) ) )

(define-inline (list-copy ls) (foldr cons '() ls))

(define-inline (list-fold f init ls) (foldl (flip f) init ls))

;; Stack Object

(define stack 'stack)
(define-record-type-variant stack (unchecked inline unsafe)
  (%make-stack lst cnt)
  (%stack?)
  (lst %stack-list %stack-list-set!)
  (cnt %stack-count %stack-count-set!))

#; ;UNUSED
(define (error-corrupted-stack loc obj) (##sys#signal-hook #:runtime-error loc "stack corrupted" obj))
(define (error-stack-underflow loc stk) (##sys#signal-hook #:limit-error loc "stack underflow" stk))
(define (error-outside-range loc obj low high) (##sys#signal-hook #:bounds-error loc "out of range" obj low high))

;; Stack List

(define-inline (%make-empty-stack) (%make-stack '() 0))

(define-inline (%stack-list-empty? stk) (null? (%stack-list stk)))
(define-inline (%stack-list-empty! stk) (%stack-list-set! stk '()))

;; Stack Count

(define-inline (%stack-count-inc! stk cnt) (%stack-count-set! stk (fx+ (%stack-count stk) cnt)))
(define-inline (%stack-count-dec! stk cnt) (%stack-count-set! stk (fx- (%stack-count stk) cnt)))

;; Stack Object

#; ;UNUSED
(define-inline (%valid-as-stack? obj)
  (and (eq? stack (%structure-tag obj))
       (fx= 2 (%structure-count obj))
       (list? (%stack-list obj))
       (fixnum? (%stack-count obj)) ) )

;; Stack Operations

(define-inline (%stack-empty? stk) (%stack-list-empty? stk))

(define-inline (%stack-empty! stk)
  (%stack-count-set! stk 0)
  (%stack-list-empty! stk) )

(define-inline (%stack-pop! stk)
  (%stack-count-dec! stk 1)
	(let ((ls (%stack-list stk)))
		(%stack-list-set! stk (cdr ls))
		(car ls) ) )

(define-inline (%stack-push/1! stk obj)
  (%stack-count-inc! stk 1)
	(%stack-list-set! stk (cons obj (%stack-list stk))) )

(define-inline (%stack-push! stk ls)
  (if (null? (cdr ls))
      (%stack-push/1! stk (car ls))
      (for-each (lambda (x) (%stack-push/1! stk x)) ls) ) )

(define-inline (%stack-node-ref loc stk idx)
  (let ((pr (list-pair-ref (%stack-list stk) idx)))
		(if (pair? pr) pr
        (error-outside-range loc idx 0 (%stack-count stk)) ) ) )

;; Helpers

(define (check-stack-underflow loc stk)
  (when (%stack-empty? stk) (error-stack-underflow loc stk))
  stk )

(define (check-fixnum-index loc fx lfx hfx)
  (unless (fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx))
  fx )

;;;

(define (make-stack) (%make-empty-stack))

(define (list->stack ls)
  (check-list 'list->stack ls)
	(let ((stk (%make-empty-stack)))
    (%stack-count-set! stk (length ls))
    (%stack-list-set! stk (list-copy ls))
    stk ) )

(define (stack? obj) (%stack? obj))

(define-check+error-type stack)

(define (stack-empty? stk) (%stack-empty? (check-stack 'stack-empty? stk)))

(define (stack-count stk) (%stack-count (check-stack 'stack-count stk)))

(define (stack-peek stk #!optional (idx 0))
  (car (%stack-node-ref 'stack-peek (check-stack 'stack-peek stk) idx)))

(define (stack-empty! stk) (%stack-empty! (check-stack 'stack-empty! stk)))

(define (stack-poke! stk obj #!optional (idx 0))
  (set-car! (%stack-node-ref 'stack-poke! (check-stack 'stack-poke! stk) idx) obj))

(define (stack-push! stk #!rest ls)
  (unless (null? ls) (%stack-push! (check-stack 'stack-push! stk) ls)))

(define (stack-cut! stk start #!optional (end (%stack-count stk)))
  (check-stack 'stack-cut! stk)
  (check-fixnum 'stack-cut! start)
  (check-fixnum 'stack-cut! end)
  (check-fixnum-index 'stack-cut! start 0 end)
  (check-fixnum-index 'stack-cut! end start (fxadd1 (%stack-count stk)))
  (let ((cnt (fx- end start)))
    (%stack-count-dec! stk cnt)
    ; From the top?
    (if (fxzero? start)
      ;then removing leading elements
      (let* ((spr (%stack-list stk))
             (epr (list-pair-ref spr (fxsub1 cnt)))
             (ls spr) )
        (%stack-list-set! stk (cdr epr))
        (set-cdr! epr '())
        ls )
      ;else removing interior elements
      (let* ((spr (%stack-node-ref 'stack-cut! stk (fxsub1 start)))
             (epr (list-pair-ref spr cnt))
             (ls (cdr spr)) )
        (set-cdr! spr (cdr epr))
        (set-cdr! epr '())
        ls ) ) ) )

(define (stack-pop! stk)
	(%stack-pop! (check-stack-underflow 'stack-pop! (check-stack 'stack-pop! stk))) )

(define (stack->list stk) (list-copy (%stack-list (check-stack 'stack->list stk))))

(define (stack-fold stk func init)
  (list-fold func init (%stack-list (check-stack 'stack-fold stk))))

(define (stack-map stk func) (map func (%stack-list (check-stack 'stack-map stk))))

(define (stack-for-each stk proc)
  (for-each proc (%stack-list (check-stack 'stack-for-each stk))))

;;; Read/Print Syntax

(define stack-literal-form
  (make-parameter 'unread
    (lambda (x)
      (case x
        ((SRFI-10 srfi-10)
          'srfi-10 )
        ((UNREAD unread)
          'unread )
        (else
          (warning 'stack-literal-form "invalid form symbol; 'srfi-10 or 'unread" x)
          (stack-literal-form))))))

(define (stack-print stk out)
  (case (stack-literal-form)
    ((srfi-10) (format out "#,(stack ~A)" (%stack-list stk)) )
    (else (format out "#<stack ~A>" (%stack-count stk)) ) ) )

(set-record-printer! stack stack-print)
(define-reader-ctor 'stack list->stack)

) ;module stack