(module yasos-stacks
        (make-stack make-ra-stack ra-stack? stack? state down push! top pop! clear! empty? size show protocol)
        (import scheme (chicken base) (chicken format)
                (except yasos object object-with-ancestors))

;;; stack interface
(define-predicate stack?)
(define-operation (pop! obj))
(define-operation (top obj))
(define-operation (push! obj x))
(define-operation (empty? obj))
(define-operation (clear! obj))
(define-operation (state obj))

;;; stack implementation with vectors
;;; (to allow a random access child)
(define (make-stack)
  (let ((vec (vector 1 2))) ;'#(pos len data ...)
    (operations ()
      ((stack? self) #t)
      ((empty? self)
       (= (vector-ref vec 0) 1))
      ((size self)
       (- (vector-ref vec 0) 1))
      ((show self . optional-arg)
       (if (null? optional-arg)
         (show self #t)
         (format (car optional-arg)
                 "#,~s~%"
                 (let loop ((k 0) (result '()))
                   (if (= k (size self))
                     (cons 'stack (reverse result))
                     (loop (+ k 1)
                           (cons (vector-ref vec (+ k 2))
                                 result)))))))
      ((state self) ; needed for inheritance
       (lambda () vec))
      ((top self)
       (if (empty? self)
         (error 'top "stack empty")
         (vector-ref vec (vector-ref vec 0))))
      ((push! self x)
       ;; update pos
       (vector-set! vec 0 (+ (vector-ref vec 0) 1))
       ;; stack full?
       (when (= (vector-ref vec 0) (vector-ref vec 1))
         ;; update len
         (vector-set! vec 1 (* 2 (vector-ref vec 1)))
         ;; update vec
         (set! vec (vector-resize vec (vector-ref vec 1) #f)))
       ;; store new value
       (vector-set! vec (vector-ref vec 0) x))
      ((pop! self)
       (if (empty? self)
         (error 'pop! "stack empty")
         (vector-set! vec 0 (- (vector-ref vec 0) 1))))
      ((clear! self)
       (set! (vector-ref vec 0) 1)))))
                 
;;; ra-stack interface
(define-predicate ra-stack?)
(define-operation (down obj k))

;;; random-access stack implementation
(define (make-ra-stack)
  (operations ((stack (make-stack)))
    ((ra-stack? self) #t)
    ((show self . optional-arg)
     (if (null? optional-arg)
       (show self #t)
       (format (car optional-arg)
               "#,~s~%"
               (let loop ((k 0) (result '()))
                 (if (= k (size self))
                   (cons 'ra-stack (reverse result))
                   (loop (+ k 1)
                         (cons (vector-ref ((state self)) (+ k 2))
                               result)))))))
    ((down self k)
     (let ((vec ((state self))))
       (if (and (integer? k) (< -1 k (size self)))
         (vector-ref vec (- (vector-ref vec 0) k))
         (error 'down "out of range" k))))))

) ; module stacks