;;;; stack.scm -*- Scheme -*-
;;;; 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
;;

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

(module stack

(;export
  make-stack
  list->stack
  stack->list
  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
  (srfi 10)
  (chicken base)
  (chicken fixnum)
  (chicken type)
  (only (chicken port) with-output-to-port)
  (only (chicken format) format)
  (only record-variants define-record-type-variant)
  (only type-checks define-check+error-type check-list check-fixnum))

#| chicken
flip
foldl
foldr
warning
:
void
declare
define-inline
define-constant
define-for-syntax
include
optional let-optionals  ;due to #!optional implementation
unless when
define-record-printer
define-reader-ctor
|#

(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) '() )
      ((fx= 0 i)  ls )
      (else       (loop (cdr ls) (fx- i 1)) ) ) ) )

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

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

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

;; Stack Type

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

(: make-stack (-> stack))
(: list->stack (list -> stack))
(: stack? (* -> boolean))
(: 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 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!))

;NOTE ref's forward defined `stack?'
(define-check+error-type stack)

(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))

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

;; Stack List

(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
    (fx= 3 (%structure-length 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 lfx fx hfx)
  (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx))
  ;cannot return useful value (singular)
  (void) )

;;;

(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 (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! 0 start end)
  (check-fixnum-index 'stack-cut! start end (fx+ (%stack-count stk) 1))
  (let ((cnt (fx- end start)))
    (%stack-count-dec! stk cnt)
    ; From the top?
    (if (fx= 0 start)
      ;then removing leading elements
      (let* (
        (spr (%stack-list stk))
        (epr (%list-pair-ref spr (fx- cnt 1)))
        (ls spr) )
        (%stack-list-set! stk (cdr epr))
        (set-cdr! epr '())
        ls )
      ;else removing interior elements
      (let* (
        (spr (%stack-node-ref 'stack-cut! stk (fx- start 1)))
        (epr (%list-pair-ref spr cnt))
        (ls (cdr spr)) )
        (set-cdr! spr (cdr epr))
        (set-cdr! epr '())
        ls ) ) ) )

(define (stack-pop! stk)
  (check-stack 'stack-pop! stk)
	(check-stack-underflow 'stack-pop! stk)
	(%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