;;;; stack.scm
;;;; 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
;;
;; - All operations inlined & primitive due to high-performance nature.

(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-map
  stack-for-each
  stack-literal-form)

(import scheme)
(import (srfi 10))
(import (chicken base))
(import (chicken fixnum))
(import (chicken type))
(import (only (chicken port) with-output-to-port))
(import (only (chicken format) format))
(import (only type-errors define-error-type error-list error-fixnum))

(include "chicken-primitive-object-inlines")
(include "inline-type-checks")

#| chicken
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
|#

;; Stack Type

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

(define-constant stack 'stack#stack)

(define stack)

;; Stack List

(define-inline (%stack-list stk)          (%structure-ref stk 1))
(define-inline (%stack-list-empty? stk)   (%null? (%stack-list stk)))
(define-inline (%stack-list-set! stk ls)  (%structure-set! stk 1 ls))
(define-inline (%stack-list-empty! stk)   (%structure-set!/immediate stk 1 '()))

;; Stack Count

(define-inline (%stack-count stk)           (%structure-ref stk 2))
(define-inline (%stack-count-set! stk cnt)  (%structure-set!/immediate stk 2 cnt))
(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

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

(define-inline (%stack? obj) (%structure-instance? obj stack))

(define-inline (%valid-as-stack? obj)
  (and
    (%fx= 3 (%structure-length obj))
    (%list? (%stack-list 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))
    (%list-for-each/1 (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-inline (%check-stack loc obj)
  (unless (%stack? obj) (error-stack loc obj))
  (unless (%valid-as-stack? obj) (error-corrupted-stack loc obj))
  obj )

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

(define-inline (%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-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))

;;;

(: make-stack (-> stack))
;
(define (make-stack) (%make-stack))

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

(: stack? (* -> boolean))
;
(define (stack? obj) (%stack? obj))

(: stack-empty? (stack -> boolean))
;
(define (stack-empty? stk) (%stack-empty? (%check-stack 'stack-empty? stk)))

(: stack-count (stack -> fixnum))
;
(define (stack-count stk) (%stack-count (%check-stack 'stack-count stk)))

(: stack-peek (stack #!optional fixnum -> *))
;
(define (stack-peek stk #!optional (idx 0)) (%car (%stack-node-ref 'stack-peek (%check-stack 'stack-peek stk) idx)))

(: stack-empty! (stack -> void))
;
(define (stack-empty! stk) (%stack-empty! (%check-stack 'stack-empty! stk)))

(: stack-poke! (stack * #!optional fixnum -> void))
;
(define (stack-poke! stk obj #!optional (idx 0)) (%set-car!/mutate (%stack-node-ref 'stack-poke! (%check-stack 'stack-poke! stk) idx) obj))

(: stack-push! (stack #!rest * -> void))
;
(define (stack-push! stk #!rest ls) (unless (%null? ls) (%stack-push! (%check-stack 'stack-push! stk) ls)))

(: stack-cut! (stack fixnum #!optional fixnum -> list))
;
(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!/immediate 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!/mutate spr (%cdr epr))
        (%set-cdr!/immediate epr '())
        ls ) ) ) )

(: stack-pop! (stack -> *))
;
(define (stack-pop! stk)
  (%check-stack 'stack-pop! stk)
	(%check-stack-underflow 'stack-pop! stk)
	(%stack-pop! stk) )

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

(: stack-fold (stack procedure * -> *))
;
(define (stack-fold stk func init) (%list-fold/1 func init (%stack-list (%check-stack 'stack-fold stk))))

(: stack-map (stack procedure -> list))
;
(define (stack-map stk func) (%list-map/1 func (%stack-list (%check-stack 'stack-map stk))))

(: stack-for-each (stack procedure -> void))
;
(define (stack-for-each stk proc) (%list-for-each/1 proc (%stack-list (%check-stack 'stack-for-each stk))))

;;; Read/Print Syntax

(define-record-printer (stack stk out) (format out (stack-literal-format) (%stack-list stk)))

(define-reader-ctor 'stack list->stack)

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

(define-constant SRFI-10-FORMAT "#,(stack ~A)")
(define-constant UNREAD-FORMAT "#<stack ~A>")

(define (stack-literal-format)
  (case (stack-literal-form)
    ((srfi-10)  SRFI-10-FORMAT )
    (else       UNREAD-FORMAT ) ) )

) ;module stack