;; FILE          "yasos.scm"
;; IMPLEMENTS    YASOS: Yet Another Scheme Object System
;; AUTHOR        Ken [dot] Dickey [at] Whidbey [dot] Com
;; DATE          1992 March 1
;; LAST UPDATED  1992 March 5
;; CHICKEN-PORT  2008 February 7
;; MAINTAINER    ju(at)jugilo(dot)de
;; LAST UPDATED  2013 October 5
;; 

;;; AUTHOR: Ken Dickey, Ken(dot)Dickey(at)Whidbey(dot)Com
;;; ported to Chicken and enhanced by Juergen Lorenz, ju(at)jugilo(dot)de
;;;
;;; COPYRIGHT (c) 1992,2008 by Kenneth A Dickey, All rights reserved.
;;;
;;;Permission is hereby granted, free of charge, to any person
;;;obtaining a copy of this software and associated documentation
;;;files (the "Software"), to deal in the Software without
;;;restriction, including without limitation the rights to use,
;;;copy, modify, merge, publish, distribute, sublicense, and/or
;;;sell copies of the Software, and to permit persons to whom
;;;the Software is furnished to do so, subject to the following
;;;conditions:
;;;
;;;The above copyright notice and this permission notice shall
;;;be included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;;OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;;HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;;WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;;FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;;OTHER DEALINGS IN THE SOFTWARE.

;; NOTES: An object system for Scheme based on the paper by
;; Norman Adams and Jonathan Rees: "Object Oriented Programming in
;; Scheme", Proceedings of the 1988 ACM Conference on LISP and 
;; Functional Programming, July 1988 [ACM #552880].

(module yasos

(export yasos
        size
        protocol
        show
        define-predicate
        (object make-instance)
        (define-operation instance? instance-dispatcher)
        (object-with-ancestors make-instance instance-dispatcher)
        (operations instance? make-instance instance-dispatcher)
        (operate-as instance-dispatcher))
(import scheme
        (only chicken error define-record-type case-lambda)
        (only extras format))

;; INSTANCE? MAKE-INSTANCE INSTANCE-DISPATCHER

;; original version

;(define make-instance 'bogus)  ;; defined below
;(define instance?     'bogus)
;
;(let ((instance-tag "instance"))
;      ;; Make a unique tag within a local scope.
;      ;; No other data object is EQ? to this tag.
;  (set! make-instance
;  (lambda (dispatcher) (cons instance-tag dispatcher)))
;  (set! instance?
;  (lambda (obj) (and (pair? obj) (eq? (car obj) instance-tag))))
;      
;(define-syntax instance-dispatcher
;  (syntax-rules ()
;    ((_ <inst>) (cdr <inst>))))

;; internal
(define-record-type instance
  (make-instance dispatcher)
  instance?
  (dispatcher instance-dispatcher))

;; DEFINE-OPERATION

;; original version
;(define-syntax define-operation
;  (syntax-rules ()
;    ((_ (<name> <inst> <arg> ...) <exp1> <exp2> ...) ;; with body
;     (define <name>
;       (letrec ((self
;                  (lambda (<inst> <arg> ...)
;                    (cond
;                      ((and (instance? <inst>) 
;                            ((instance-dispatcher <inst>) self))
;                         => (lambda (operation) (operation <inst> <arg> ...)))
;                      (else <exp1> <exp2> ...)))))
;         self)))
;    ((_ (<name> <inst> <arg> ...)) ;; no body
;     (define-operation (<name> <inst> <arg> ...)
;       (error "Operation not handled" '<name>
;              (format #f (if (instance? <inst>) "#<INSTANCE>" "~s") <inst>))))))

;; the following version handles arbitrary lambda-lists as args
(define-syntax define-operation
  (syntax-rules ()
    ((_ (name inst arg ...) xpr . xprs) ; ordinary argument list
     (define name
       (letrec (
         (self
           (lambda (inst arg ...)
             (cond
               ((and (instance? inst) 
                     ((instance-dispatcher inst) self))
                => (lambda (operation) (operation inst arg ...)))
               (else xpr . xprs))))
         )
         self)))
    ((_ (name inst . args) xpr . xprs) ; dotted argument list
     (define name
       (letrec (
         (self
           (lambda (inst . args)
             (cond
               ((and (instance? inst) 
                     ((instance-dispatcher inst) self))
                => (lambda (operation)
                     (apply operation inst args)))
               (else xpr . xprs))))
         )
         self)))
    ((_ (name inst . args)) ;; no body
     (define-operation (name inst . args)
       (error "Operation not handled" 'name
              (format #f
                      (if (instance? inst) "#YASOS-INSTANCE" "~s")
                      inst))))))

;; DEFINE-PREDICATE
(define-syntax define-predicate
  (syntax-rules ()
    ((_ name)
     (define-operation (name obj) #f))))

;; OBJECT (deprecated, use operations instead)

;; original version
;(define-syntax object
;  (syntax-rules ()
;    ((_ ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
;     (let ((table
;             (list (cons <name>
;                   (lambda (<self> <arg> ...) <exp1> <exp2> ...)) ...)))
;       (make-instance
;         (lambda (op)
;           (cond ((assq op table) => cdr)
;                 (else #f))))))))

(define-syntax object
  (syntax-rules ()
    ((_ ((name inst . args) xpr . xprs) ...)
     (let ((table
             (list (cons name
                         (lambda (inst . args) xpr . xprs)) ...)))
       (make-instance
         (lambda (op)
           (cond
             ((assq op table) => cdr)
             ((eq? op protocol)
              (lambda (obj . optional-sym)
                (if (null? optional-sym)
                  '(name ...)
                  (assq (car optional-sym)
                        '((name inst . args) ...)))))
             (else #f))))))))

;; OBJECT with MULTIPLE INHERITANCE  {First Found Rule}
;; (deprecated, use operations instead)

;; original version
;(define-syntax object-with-ancestors
;  (syntax-rules ()
;    ((_ ((<ancestor1> <init1>) ...) <operation> ...)
;     (let ((<ancestor1> <init1>) ... )
;       (let ((child (object <operation> ...)))
;         (make-instance
;           (lambda (op) 
;             (or ((instance-dispatcher child) op)
;                 ((instance-dispatcher <ancestor1>) op) ...))))))))

(define-syntax object-with-ancestors
  (syntax-rules ()
    ((_ ((ancestor init) ...) operation ...)
     (let ((ancestor init) ...)
       (let ((child (object operation ...)))
         (make-instance
           (lambda (op) 
             (if (eq? op protocol)
               (lambda (obj . optional-sym)
                 (if (null? optional-sym)
                   (append (protocol child)
                           (list (protocol ancestor))
                           ...)
                   (let ((sym (car optional-sym)))
                     (or (protocol child sym)
                         (protocol ancestor sym)
                         ...))))
               (or ((instance-dispatcher child) op)
                 ((instance-dispatcher ancestor) op)
                 ...)))))))))

;; OPERATIONS
(define-syntax operations
  (syntax-rules ()
    ((_ () ((name inst . args) xpr . xprs) ...)
     (let ((table
             (list (cons name
                         (lambda (inst . args) xpr . xprs)) ...)))
       (make-instance
         (lambda (op)
           (cond
             ((assq op table) => cdr)
             ((eq? op protocol)
              (lambda (obj . optional-sym)
                (if (null? optional-sym)
                  '(name ...)
                  (assq (car optional-sym)
                        '((name inst . args) ...)))))
             (else #f))))))
    ((_ ((ancestor0 init0) (ancestor1 init1) ...) operation ...)
     (let ((ancestor0 init0) (ancestor1 init1) ...)
       (let ((child (operations () operation ...)))
         (make-instance
           (lambda (op) 
             (if (eq? op protocol)
               (lambda (obj . optional-sym)
                 (if (null? optional-sym)
                   (append (protocol child)
                           (list (protocol ancestor0))
                           (list (protocol ancestor1))
                           ...)
                   (let ((sym (car optional-sym)))
                     (or (protocol child sym)
                         (protocol ancestor0 sym)
                         (protocol ancestor1 sym)
                         ...))))
               (or ((instance-dispatcher child) op)
                 ((instance-dispatcher ancestor0) op)
                 ((instance-dispatcher ancestor1) op)
                 ...)))))))))

    
;; OPERATE-AS  {a.k.a. send-to-super}
;; used in operations/methods
(define-syntax operate-as
  (syntax-rules ()
    ((_ super op self arg ...)
     (((instance-dispatcher super) op) self arg ...))))

(define-operation (show obj . optional-arg)
  (if (null? optional-arg)
    (show obj #t)
    (if (instance? obj)
       (format (car optional-arg) "<yasos-instance: ~s>~%" obj)
       (format (car optional-arg) "<not-a-yasos-instance: ~s>~%" obj))))
 
(define-operation (size obj)
  ;; default behaviour
  (cond
    ((vector? obj) (vector-length obj))
    ((list? obj) (length obj))
    ((string? obj) (string-length obj))
    ((pair? obj) 2)
    ((char? obj) 1)
    (else (error 'size
                 (format #f "~s doesn't accept operation" obj)))))

(define-operation (protocol obj . args) #f)

(define yasos
  (let ((lst '(define-predicate define-operation operations
               object object-with-ancestors operate-as protocol size
               show)))
    (case-lambda
      (() lst)
      ((arg)
       (case arg
         ((show)
          '(procedure
             ((_ obj)
              "prints obj with format to stdout")
             ((_ obj arg)
              "prints obj with format to arg")))
         ((size)
          '(procedure (result)
             ((_ obj)
              #t
              (and (fixnum result) (fx>= result 0)))))
         ((protocol)
          '(procedure (result)
             ((_ obj)
              (instance? obj)
              (and (list? result) "the names of operations obj accepts"))
             ((_ obj sym)
              (and (instance? obj) (symbol? sym))
              (and (list? result) "signature of exported operation sym"))))
         ((define-predicate)
          '(macro ()
                  ((_ name)
                   (identifier? name)
                   (procedure? result))))
         ((define-operation)
          '(macro ()
                  ((_ (name inst . args) . xprs)
                   (and (instance? inst) (identifier? name))
                   (procedure? result))))
         ((operations)
          '(macro ()
                  ((_ () ((name self . args) xpr . xprs) ...)
                   (and (identifier? name) (instance? self))
                   "multiple operations named name ... with given signature")
                  ((_ ((ancestor init) ...) op . ops))
                  (and (instance? ancestor) ... (operation? op) ...)
                  "new or overridden operaions op . ops"))
         ((object)
          '(macro ()
                  ((_ ((name self . args) xpr . xprs) ...)
                   (and (identifier? name) (instance? self))
                   "multiple operations named name ... with given signature")))
         ((object-with-ancestors)
          '(macro ()
                  ((_ ((ancestor init) ...) op . ops))
                  (and (instance? ancestor) ... (operation? op) ...)
                  "new or overridden operaions op . ops"))
         ((operate-as)
          '(macro ()
                  ((_ super op self . args)
                   (and (instance? super)
                        (instance? self)
                        (operation? op))
                   "send to super")))
         (else
           (error 'yasos "choose one of" lst)))))))

) ;module yasos


(module stacks
(export make-stack make-ra-stack ra-stack? stack? state down push! top pop! clear! empty? size show protocol)
(import scheme
        (only chicken when error vector-resize)
        (only extras 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
                 
;;; queues with amortized constant-time access to data
(module queues   
(export make-queue queue? empty? protocol size state front clear! deq! enq!)
(import scheme
        (only chicken when error)
        (only extras format)
        (except yasos object object-with-ancestors))
                 
;; interface     
(define-predicate queue?)
(define-operation (empty? obj))
(define-operation (clear! obj))
(define-operation (front obj))
(define-operation (deq! obj))
(define-operation (enq! obj x))
(define-operation (state obj))
                 
;; implementation
(define (make-queue)
  (let ((in '()) (out '()))
    (operations ()
      ((queue? self) #t)
      ((empty? self) (and (null? in) (null? out)))
      ((size self) (+ (length in) (length out)))
      ((show self . optional-arg)
       (if (null? optional-arg)
         (show self #t)
         (format (car optional-arg)
                 "#,~s~%"
                 (cons 'queue (append out (reverse in))))))
      ((state self) ; for inheritance
       (lambda () (vector in out)))
      ((front self)
       (if (and (null? in) (null? out))
         (error 'front "queue empty")
         (begin
           (when (null? out)
             (set! out (reverse in))
             (set! in '()))
           (car out))))
      ((enq! self x) (set! in (cons x in)))
      ((deq! self)
       (if (and (null? in) (null? out))
         (error 'deq! "queue empty")
         (begin
           (when (null? out)
             (set! out (reverse in))
             (set! in '()))
           (set! out (cdr out)))))
      ((clear! self) (set! in '()) (set! out '())))))

) ; module queues

(module points
(export point? make-point-cartesian make-point-polar x y rho theta
        translate! scale! rotate! distance)
(import scheme
        (only extras format)
        (except yasos object object-with-ancestors operate-as))
                 
(define-predicate point?)
(define-operation (x obj))
(define-operation (y obj))
(define-operation (rho obj))
(define-operation (theta obj))
(define-operation (translate! obj dx dy))
(define-operation (scale! obj factor))
(define-operation (rotate! obj angle))
(define-operation (distance obj other))

;; internal
(define pi (acos -1))
(define (normalize theta)
  (/ (remainder (floor (round (* 10E12 theta)))
                (floor (round (* 20E12 pi))))
     10E12))
(define (r2 x) ; round to precision 2
 (/ (round (* x 100)) 100))
(define (point-maker %x %y %rho %theta)
  (operations ()
    ((point? self) #t)
    ((size self) 2)
    ((show self . optional-arg)
     (if (null? optional-arg)
       (show self #t)
       (format (car optional-arg)
               "#,(point x: ~s y: ~s rho: ~s theta: ~s)~%"
               (r2 %x) (r2 %y) (r2 %rho) (r2 %theta))))
    ((x self) %x)
    ((y self) %y)
    ((rho self) %rho)
    ((theta self) %theta)
    ((distance self other)
     (let ((dx (- %x (x other))) (dy (- %y (y other))))
       (sqrt (+ (* dx dx) (* dy dy)))))
    ((translate! self dx dy)
     (set! %x (+ %x dx))
     (set! %y (+ %y dy))
     (set! %rho (sqrt (+ (* %x %x) (* %y %y))))
     (set! %theta (atan %y %x)))
    ((scale! self factor)
     (set! %rho (* %rho factor))
     (set! %x (* %rho (cos %theta)))
     (set! %y (* %rho (sin %theta))))
    ((rotate! self angle)
     (set! %theta (normalize (+ %theta angle)))
     (set! %x (* %rho (cos %theta)))
     (set! %y (* %rho (sin %theta))))
    ))

(define (make-point-cartesian x y)
  (point-maker x y (sqrt (+ (* x x) (* y y))) (atan y x)))

(define (make-point-polar rho theta)
  (point-maker (* rho (cos theta)) (* rho (sin theta)) rho (normalize theta)))

) ; points

(require-library simple-tests)
(import yasos stacks queues points simple-tests)
(define st (make-stack))
(do ((k 9 (- k 1)))
  ((negative? k))
  (push! st k))
(show st)

(define st1 (make-stack))
(push! st1 'a)
(push! st1 'b)
(push! st1 'c)
(show st1)

(define rst (make-ra-stack))
(do ((k 9 (- k 1)))
  ((negative? k))
  (push! rst (* 100 k)))
(show rst)

(define qu (make-queue))
(enq! qu 0)
(enq! qu 1)
(enq! qu 2)
(enq! qu 3)
(show qu)

(define cart (make-point-cartesian 1 2))
(show cart)
(define pol (make-point-polar 1 (acos -1)));3.14159))
(show pol)