source: project/release/5/yasos/trunk/tests/run.scm @ 36391

(import scheme (chicken base) (chicken format) (chicken port)
        yasos (prefix yasos-stacks stack.) (prefix yasos-queues queue.)
        yasos-points yasos-collections test)

 ;;;-----------------------
 ;; person interface
 ;;------------------------
 
 (define-predicate person?)
 (define-operation (name obj))
 (define-operation (age obj))
 (define-operation (set-age! obj new-age))
 (define-operation (ssn obj password)) ;; Social Security # is protected
 (define-operation (new-password obj old-passwd new-passwd))
 (define-operation (bad-password obj bogus-passwd)
   ;; assume internal (design) error
   (error (format #f "Bad Password: ~s given to ~a~%"
           bogus-passwd
           (show obj))))
 
 ;;----------------------------------
 ;; person implementation
 ;;----------------------------------
 
 (define (make-person a-name an-age a-ssn the-password)
   (operations ()
     ((person? self) #t)
     ((show self . optional-arg)
      (if (null? optional-arg)
        (show self #t)
        (format (car optional-arg)
                "#<Person: ~a age: ~a>~%"
                (name self) (age self))))
     ((name self) a-name)
     ((age self) an-age)
     ((ssn self password)
       (if (equal? password the-password)
         a-ssn
         (bad-password self password)))
     ((new-password self old-passwd new-passwd)
       (cond
         ((equal? old-passwd the-password) (set! the-password new-passwd) self)
         (else (bad-password self old-passwd))))
     ((bad-password self bogus-passwd)
       (format #t "Bad password: ~s~%" bogus-passwd)) ;; let user recover
     ((set-age! self val) (set! an-age val) an-age)
     ))
 
 ;;;---------------------------------------------------------------
 ;; account-history and bank-account interfaces
 ;;----------------------------------------------------------------
  
 (define-predicate bank-account?)
 (define-predicate account-history?)
 (define-operation (current-balance obj pin))
 (define-operation (add obj amount))
 (define-operation (withdraw obj amount pin))
 (define-operation (get-pin obj master-password))
 (define-operation (get-account-history obj master-password))
 
 ;;----------------------------------------------
 ;; account-history implementation
 ;;----------------------------------------------
 
 ;; put access to bank database and report generation here
 (define (make-account-history initial-balance a-pin master-password)
   ;; history is a simple list of balances -- no transaction times
   (letrec 
     ((history (list initial-balance))
      (balance (lambda () (car history))) ; balance is a function
      (remember
        (lambda (datum) (set! history (cons datum history)))))
     (operations ()
       ((account-history? self) #t)
       ((add self amount) ;; bank will accept money without a password
         (remember (+ amount (balance)))
         ;; print new balance
         (format #t "New balance: $~a~%" (balance)))
       ((withdraw self amount pin)
         (cond
           ((not (equal? pin a-pin)) (bad-password self pin))
           ((< (- (balance) amount) 0)
             (format 
               #t
               "No overdraft~% Can't withdraw more than you have: $~a~%"
               (balance)))
           (else
             (remember (- (balance) amount))
             (format #t "New balance: $~a~%" (balance)))))
       ((current-balance self password)
         (if (or (eq? password master-password) (equal? password a-pin))
           (format #t "Your Balance is $~a~%" (balance))
           (bad-password self password)))
       ;; only bank has access to account history
       ((get-account-history self password)
         (if (eq? password master-password)
           history
           (bad-password self password))))))
 
 ;;;------------------------------------------
 ;; bank-account implementation
 ;;-------------------------------------------
 
 (define (make-account a-name an-age a-ssn a-pin initial-balance master-password)
   (operations (
     (customer (make-person a-name an-age a-ssn a-pin))
     (account (make-account-history initial-balance a-pin master-password))
     )
     ((bank-account? self) #t)
     ((show self . optional-arg)
      (if (null? optional-arg)
        (show self #t)
        (format (car optional-arg)
                "#<Bank-Customer ~a>~%"
                (name self))))
     ((get-pin self password)
       (if (eq? password master-password)
         a-pin
         (bad-password self password)))
     ((get-account-history self password)
       ((operate-as account get-account-history) self password))
       ;(operate-as account get-account-history self password))
     ;; our bank is very conservative...
     ((bad-password self bogus-passwd)
       (format #t "~%CALL THE POLICE!!~%"))
     ;; protect the customer as well
     ((ssn self password)
       ((operate-as customer ssn) self password))
       ;(operate-as customer ssn self password))
     ))
 
 ;;; eof yasos-examples.scm
(define fred  (make-person  "Fred"  19 "573-19-4279" 'FadeCafe))
(define sally (make-account "Sally" 26 "629-26-9742" 'FeedBabe 263 'bank-password))

(test-group "accounts"

    (test-assert (person? fred))
    (test-assert (person? sally))
    (test-assert (bank-account? sally))
    (test-assert (not (bank-account? fred)))
    (test-assert (string=? (with-output-to-string (lambda () (show fred)))
              "#<Person: Fred age: 19>\n"))
    (test-assert (string=? (ssn fred 'FadeCafe) "573-19-4279"))
    (test-assert (string=? (with-output-to-string (lambda () (show sally)))
              "#<Bank-Customer Sally>\n"))
    (test-assert (string=? (with-output-to-string (lambda () (ssn sally 'bogus)))
              "\nCALL THE POLICE!!\n"))
    (test-assert (string=? (ssn sally 'FeedBabe) "629-26-9742"))
    (test-assert (string=? (with-output-to-string (lambda() (current-balance sally 'FeedBabe)))
              "Your Balance is $263\n"))
    (test-assert (string=?
      (begin (add sally 200)
             (add sally 300)
             (withdraw sally 400 'FeedBabe)
             (with-output-to-string (lambda() (current-balance sally 'FeedBabe))))
      "Your Balance is $363\n"))
    (test-assert (equal? (get-account-history sally 'bank-password)
            '(363 763 463 263)))
    (test-assert (string=? (with-output-to-string
                (lambda () (withdraw sally 150 (get-pin sally 'bank-password))))
              "New balance: $213\n"))
    (test-assert (equal? (get-account-history sally 'bank-password)
            '(213 363 763 463 263)))
    (test-assert (string=? (with-output-to-string (lambda () (ssn fred 'bogus)))
              "Bad password: bogus\n"))
    (test-assert (equal? (protocol sally)
            '(bank-account? show get-pin get-account-history
                            bad-password ssn
                            (person? show name age ssn new-password
                                     bad-password set-age!)
                            (account-history? add withdraw
                                              current-balance
                                              get-account-history))))
    (test-assert (equal? (protocol sally 'ssn)
                         '(ssn self password)))
    )

(define eps 0.0001)
(define cart (make-point-cartesian -1 0))
(define pol (make-point-polar 1 (acos -1)))

(test-group "points"
            
    (test-assert (< (distance cart pol) eps))
    (test-assert (= (rho cart) 1))
    (scale! pol 5)
    (test-assert (< (abs (- (x pol) -5)) eps))
    (translate! cart 1 1)
    (test-assert (= (x cart) 0))
    (test-assert (= (y cart) 1))
    (rotate! pol 3.14159)
    (test-assert (< (distance pol (make-point-cartesian 5 0)) eps))
    (test-assert (= (size pol) 2))
    )

(define st (stack.make-stack))
(define rst (stack.make-ra-stack))

(test-group "stacks"

    (test-assert (stack.stack? st))
    (test-assert (not (stack.ra-stack? st)))
    (test-assert (stack.empty? st))
    (stack.push! st 0)
    (stack.push! st 1)
    (stack.push! st 2)
    (test-assert (= (stack.size st) 3))
    (test-assert (not (stack.empty? st)))
    (test-assert (= (stack.top st) 2))
    (stack.pop! st)
    (test-assert (= (stack.top st) 1))
    (stack.pop! st)
    (test-assert (= (stack.size st) 1))
    (stack.clear! st)
    (test-assert (stack.empty? st))

    (test-assert (stack.ra-stack? rst))
    (test-assert (stack.stack? rst))
    (stack.push! rst 0)
    (stack.push! rst 1)
    (stack.push! rst 2)
    (test-assert (= (stack.down rst 1) 1))
    (test-assert (= (stack.top rst) 2))
    (stack.pop! rst)
    (test-assert (= (stack.top rst) 1))
    (test-assert (= (stack.down rst 1) 0))
    (test-assert (equal? (protocol rst)
                         '(ra-stack? show down (stack? empty? size show state top push!
                                                       pop! clear!))))
    (test-assert (equal? (protocol rst 'down) '(down self k)))
    )

(define qu (queue.make-queue))

(test-group "queues"

    (test-assert (queue.queue? qu))
    (test-assert (not (queue.queue? #f)))
    (test-assert (queue.empty? qu))
    (queue.enq! qu 0)
    (queue.enq! qu 1)
    (queue.enq! qu 2)
    (test-assert (= (queue.size qu) 3))
    (test-assert (not (queue.empty? qu)))
    (test-assert (= (queue.front qu) 0))
    (queue.deq! qu)
    (test-assert (= (queue.front qu) 1))
    (queue.deq! qu)
    (test-assert (= (queue.size qu) 1))
    (queue.clear! qu)
    (queue.empty? qu)
    (test-assert (equal? (protocol qu)
                        '(queue? empty? size show state front enq! deq! clear!)))
    )


;; sample collection -- simple-table .. also a table

(define-predicate table?)
(define-operation (lookup table key failure-object))
(define-operation (associate! table key value)) ;; returns key
(define-operation (remove! table key))          ;; returns value

(define (make-simple-table)
  (let ( (table (list)) )
    (object
      ;; table behaviors
      ((table? self) #t)
      ((size self) (size table))
      ((print self port) (format port "#<simple-table>"))
      ((lookup self key failure-object)
       (cond 
         ((assq key table) => cdr)
         (else failure-object)
      ))
      ((associate! self key value)
       (cond
         ((assq key table) => (lambda (bucket) (set-cdr! bucket value) key))
         (else 
           (set! table (cons (cons key value) table))
           key)
      ))
      ((remove! self key) ;; returns old value
       (cond
         ((null? table) (error "table:remove! key not found: " key))
         ((eq? key (caar table))
          (let ( (value (cdar table)) )
             (set! table (cdr table))
             value)
         )
         (else
           (let loop ( (last table) (this (cdr table)) )
             (cond
               ((null? this) (error "table:remove! key not found: " key))
               ((eq? key (caar this))
                (let ( (value (cdar this)) )
                  (set-cdr! last (cdr this))
                 value)
               )
               (else
                (loop (cdr last) (cdr this)))
         ) ) )
      ))
      ;; collection behaviors
      ((collection? self) #t)
      ((gen-keys self) (list->generator (map car table)))
      ((gen-elts self) (list->generator (map cdr table)))
      ((for-each-key self proc)
       (for-each (lambda (bucket) (proc (car bucket))) table)
      )
      ((for-each-elt self proc)
       (for-each (lambda (bucket) (proc (cdr bucket))) table)
      )
) ) )

(define t (make-simple-table))

(test-group "collections"

    (for-each-elt
         (lambda (item)
           (print "item: " item))
         '(1 2 3))
    (test-assert (collection? t))
    (test-assert (empty? t))
    (associate! t 'a 1)
    (associate! t 'b 2)
    (test 2 (size t))
    (let ((g (gen-keys t)))
      (test "gen-keys" '(b a) (list (g) (g))))
    (let ((g (gen-elts t)))
      (test "gen-elts" '(2 1) (list (g) (g))))
    (test "map-keys" #(b a) (map-keys identity t))
    (test "map-elts" #(2 1) (map-elts identity t))
    (test "reduce" 3 (reduce + 0 t))
    (test "reduce-items" 3 (reduce-items (lambda (item ax)
                                           (+ (cadr item) ax)) 0 t))
    (test "reduce*" 1 (reduce* min '(1 2 3 4 10 5 6 8 7 9)))
    (test "sort!" #(1 2 3 4 5) (sort! (lambda (i vi j vj) (< vi vj))
                                      #( 5 2 4 3 1)))
    (test "sort" #(7 8 9 10 11) (sort (lambda (i vi j vj) (< vi vj))
                                    '( 11 8 10 7 9)))
    
    )