Changeset 8680 in project


Ignore:
Timestamp:
02/23/08 16:52:36 (11 years ago)
Author:
svnwiki
Message:

Changes applied for Anonymous (71.38.23.88) through svnwiki:

File:
1 edited

Legend:

Unmodified
Added
Removed
  • wiki/yasos

    r8679 r8680  
    3636
    3737=== Examples
    38 
    39  ;;;===============
    40  ;;;file yasos-examples.scm
    41  ;;;===============
    42 
    43  (declare (unit yasos-examples))
    44  (require-extension syntax-case yasos format)
    45 
    46  ;;----------------------------
    47  ;; general operations
    48  ;;----------------------------
    49 
    50  (define-operation (print-obj obj port)
    51    (format port
    52      ;; if an instance does not have a print-obj operation..
    53      (if (instance? obj) "#<INSTANCE>~%" "#<NOT-AN-INSTANCE: ~s>~%") obj))
    54 
    55  (define-operation (size-obj obj)
    56    ;; default behavior
    57    (cond
    58      ((vector? obj) (vector-length obj))
    59      ((list? obj) (length obj))
    60      ((pair? obj) 2)
    61      ((string? obj) (string-length obj))
    62      ((char? obj) 1)
    63      (else
    64        (error "Operation not supported: size-obj" obj))))
    65 
    66  ;;----------------------
    67  ;; point interface
    68  ;;----------------------
    69 
    70  (define-predicate point?) ;; answers #f  by default
    71  (define-operation (x obj))
    72  (define-operation (y obj))
    73  (define-operation (set-x! obj new-x))
    74  (define-operation (set-y! obj new-y))
    75 
    76  ;;--------------------------------
    77  ;; point implementation
    78  ;;--------------------------------
    79 
    80  (define (make-point the-x the-y)
    81    (object
    82      ((point? self) #t) ;; yes, this is a point object
    83      ((x self) the-x)
    84      ((y self) the-y)
    85      ((set-x! self val)
    86        (set! the-x val)
    87        the-x)
    88      ((set-y! self val)
    89        (set! the-y val)
    90        the-y)
    91      ((size-obj self) 2)
    92      ((print-obj self port)
    93        (format port "#<point: ~a ~a>~%" (x self) (y self)))))
    94 
    95  ;;-----------------------------------------
    96  ;; 3D point interface additions
    97  ;;-----------------------------------------
    98 
    99  (define-predicate point-3d?) ;; #f by defualt
    100  (define-operation (z obj))
    101  (define-operation (set-z! obj new-z))
    102 
    103  ;;------------------------------------
    104  ;; 3D point implementation
    105  ;;------------------------------------
    106 
    107  (define (make-point-3d the-x the-y the-z)
    108    (object-with-ancestors ( (a-point (make-point the-x the-y)) )
    109      ((point-3d? self) #t)
    110      ((z self) the-z)
    111      ((set-z! self val) (set! the-z val) the-z)
    112      ;; override inherited size-obj and print-obj operations
    113      ((size-obj self) 3)
    114      ((print-obj self port)
    115        (format port "#<3d-point: ~a ~a ~a>~%" (x self) (y self) (z self)))))
    116 
    117  ;;;-----------------------
    118  ;; person interface
    119  ;;------------------------
    120 
    121  (define-predicate person?)
    122  (define-operation (name obj))
    123  (define-operation (age obj))
    124  (define-operation (set-age! obj new-age))
    125  (define-operation (ssn obj password)) ;; Social Security # is protected
    126  (define-operation (new-password obj old-passwd new-passwd))
    127  (define-operation (bad-password obj bogus-passwd)
    128    ;; assume internal (design) error
    129    (error (format #f "Bad Password: ~s given to ~a~%"
    130            bogus-passwd
    131            (print-obj obj #f))))
    132 
    133  ;;----------------------------------
    134  ;; person implementation
    135  ;;----------------------------------
    136 
    137  (define (make-person a-name an-age a-ssn the-password)
    138    (object
    139      ((person? self) #t)
    140      ((name self) a-name)
    141      ((age self) an-age)
    142      ((set-age! self val) (set! an-age val) an-age)
    143      ((ssn self password)
    144        (if (equal? password the-password)
    145          a-ssn
    146          (bad-password self password)))
    147      ((new-password self old-passwd new-passwd)
    148        (cond
    149          ((equal? old-passwd the-password) (set! the-password new-passwd) self)
    150          (else (bad-password self old-passwd))))
    151      ((bad-password self bogus-passwd)
    152        (format #t "Bad password: ~s~%" bogus-passwd)) ;; let user recover
    153      ((print-obj self port)
    154        (format port "#<Person: ~a age: ~a>~%" (name self) (age self)))))
    155 
    156 ;;;---------------------------------------------------------------
    157 ;; account-history and bank-account interfaces
    158 ;;----------------------------------------------------------------
    159 
    160 (define-predicate bank-account?)
    161 (define-operation (current-balance obj pin))
    162 (define-operation (add obj amount))
    163 (define-operation (withdraw obj amount pin))
    164 (define-operation (get-pin obj master-password))
    165 (define-operation (get-account-history obj master-password))
    166 
    167 ;;----------------------------------------------
    168 ;; account-history implementation
    169 ;;----------------------------------------------
    170 
    171 ;; put access to bank database and report generation here
    172 (define (make-account-history initial-balance a-pin master-password)
    173   ;; history is a simple list of balances -- no transaction times
    174   (letrec
    175     ((history (list initial-balance))
    176      (balance (lambda () (car history))) ; balance is a function
    177      (remember
    178        (lambda (datum) (set! history (cons datum history)))))
     38  ;;;===============
     39  ;;;file yasos-examples.scm
     40  ;;;===============
     41 
     42  (declare (unit yasos-examples))
     43  (require-extension syntax-case yasos format)
     44 
     45  ;;----------------------------
     46  ;; general operations
     47  ;;----------------------------
     48 
     49  (define-operation (print-obj obj port)
     50    (format port
     51      ;; if an instance does not have a print-obj operation..
     52      (if (instance? obj) "#<INSTANCE>~%" "#<NOT-AN-INSTANCE: ~s>~%") obj))
     53 
     54  (define-operation (size-obj obj)
     55    ;; default behavior
     56    (cond
     57      ((vector? obj) (vector-length obj))
     58      ((list? obj) (length obj))
     59      ((pair? obj) 2)
     60      ((string? obj) (string-length obj))
     61      ((char? obj) 1)
     62      (else
     63        (error "Operation not supported: size-obj" obj))))
     64 
     65  ;;----------------------
     66  ;; point interface
     67  ;;----------------------
     68 
     69  (define-predicate point?) ;; answers #f  by default
     70  (define-operation (x obj))
     71  (define-operation (y obj))
     72  (define-operation (set-x! obj new-x))
     73  (define-operation (set-y! obj new-y))
     74 
     75  ;;--------------------------------
     76  ;; point implementation
     77  ;;--------------------------------
     78 
     79  (define (make-point the-x the-y)
    17980    (object
    180       ((bank-account? self) #t)
    181       ((add self amount) ;; bank will accept money without a password
    182         (remember (+ amount (balance)))
    183         ;; print new balance
    184         (format #t "New balance: $~a~%" (balance)))
    185       ((withdraw self amount pin)
     81      ((point? self) #t) ;; yes, this is a point object
     82      ((x self) the-x)
     83      ((y self) the-y)
     84      ((set-x! self val)
     85        (set! the-x val)
     86        the-x)
     87      ((set-y! self val)
     88        (set! the-y val)
     89        the-y)
     90      ((size-obj self) 2)
     91      ((print-obj self port)
     92        (format port "#<point: ~a ~a>~%" (x self) (y self)))))
     93 
     94  ;;-----------------------------------------
     95  ;; 3D point interface additions
     96  ;;-----------------------------------------
     97 
     98  (define-predicate point-3d?) ;; #f by defualt
     99  (define-operation (z obj))
     100  (define-operation (set-z! obj new-z))
     101 
     102  ;;------------------------------------
     103  ;; 3D point implementation
     104  ;;------------------------------------
     105 
     106  (define (make-point-3d the-x the-y the-z)
     107    (object-with-ancestors ( (a-point (make-point the-x the-y)) )
     108      ((point-3d? self) #t)
     109      ((z self) the-z)
     110      ((set-z! self val) (set! the-z val) the-z)
     111      ;; override inherited size-obj and print-obj operations
     112      ((size-obj self) 3)
     113      ((print-obj self port)
     114        (format port "#<3d-point: ~a ~a ~a>~%" (x self) (y self) (z self)))))
     115 
     116  ;;;-----------------------
     117  ;; person interface
     118  ;;------------------------
     119 
     120  (define-predicate person?)
     121  (define-operation (name obj))
     122  (define-operation (age obj))
     123  (define-operation (set-age! obj new-age))
     124  (define-operation (ssn obj password)) ;; Social Security # is protected
     125  (define-operation (new-password obj old-passwd new-passwd))
     126  (define-operation (bad-password obj bogus-passwd)
     127    ;; assume internal (design) error
     128    (error (format #f "Bad Password: ~s given to ~a~%"
     129            bogus-passwd
     130            (print-obj obj #f))))
     131 
     132  ;;----------------------------------
     133  ;; person implementation
     134  ;;----------------------------------
     135 
     136  (define (make-person a-name an-age a-ssn the-password)
     137    (object
     138      ((person? self) #t)
     139      ((name self) a-name)
     140      ((age self) an-age)
     141      ((set-age! self val) (set! an-age val) an-age)
     142      ((ssn self password)
     143        (if (equal? password the-password)
     144          a-ssn
     145          (bad-password self password)))
     146      ((new-password self old-passwd new-passwd)
    186147        (cond
    187           ((not (equal? pin a-pin)) (bad-password self pin))
    188           ((< (- (balance) amount) 0)
    189             (format
    190               #t
    191               "No overdraft~% Can't withdraw more than you have: $~a~%"
    192               (balance)))
    193           (else
    194             (remember (- (balance) amount))
    195             (format #t "New balance: $~a~%" (balance)))))
    196       ((current-balance self password)
    197         (if (or (eq? password master-password) (equal? password a-pin))
    198           (format #t "Your Balance is $~a~%" (balance))
     148          ((equal? old-passwd the-password) (set! the-password new-passwd) self)
     149          (else (bad-password self old-passwd))))
     150      ((bad-password self bogus-passwd)
     151        (format #t "Bad password: ~s~%" bogus-passwd)) ;; let user recover
     152      ((print-obj self port)
     153        (format port "#<Person: ~a age: ~a>~%" (name self) (age self)))))
     154
     155  ;;;---------------------------------------------------------------
     156  ;; account-history and bank-account interfaces
     157  ;;----------------------------------------------------------------
     158 
     159  (define-predicate bank-account?)
     160  (define-operation (current-balance obj pin))
     161  (define-operation (add obj amount))
     162  (define-operation (withdraw obj amount pin))
     163  (define-operation (get-pin obj master-password))
     164  (define-operation (get-account-history obj master-password))
     165 
     166  ;;----------------------------------------------
     167  ;; account-history implementation
     168  ;;----------------------------------------------
     169 
     170  ;; put access to bank database and report generation here
     171  (define (make-account-history initial-balance a-pin master-password)
     172    ;; history is a simple list of balances -- no transaction times
     173    (letrec
     174      ((history (list initial-balance))
     175       (balance (lambda () (car history))) ; balance is a function
     176       (remember
     177         (lambda (datum) (set! history (cons datum history)))))
     178      (object
     179        ((bank-account? self) #t)
     180        ((add self amount) ;; bank will accept money without a password
     181          (remember (+ amount (balance)))
     182          ;; print new balance
     183          (format #t "New balance: $~a~%" (balance)))
     184        ((withdraw self amount pin)
     185          (cond
     186            ((not (equal? pin a-pin)) (bad-password self pin))
     187            ((< (- (balance) amount) 0)
     188              (format
     189                #t
     190                "No overdraft~% Can't withdraw more than you have: $~a~%"
     191                (balance)))
     192            (else
     193              (remember (- (balance) amount))
     194              (format #t "New balance: $~a~%" (balance)))))
     195        ((current-balance self password)
     196          (if (or (eq? password master-password) (equal? password a-pin))
     197            (format #t "Your Balance is $~a~%" (balance))
     198            (bad-password self password)))
     199        ;; only bank has access to account history
     200        ((get-account-history self password)
     201          (if (eq? password master-password)
     202            history
     203            (bad-password self password))))))
     204 
     205  ;;;------------------------------------------
     206  ;; bank-account implementation
     207  ;;-------------------------------------------
     208 
     209  (define (make-account a-name an-age a-ssn a-pin initial-balance master-password)
     210    (object-with-ancestors
     211      ((customer (make-person a-name an-age a-ssn a-pin))
     212       (account (make-account-history initial-balance a-pin master-password)))
     213      ((get-pin self password)
     214        (if (eq? password master-password)
     215          a-pin
    199216          (bad-password self password)))
    200       ;; only bank has access to account history
    201217      ((get-account-history self password)
    202         (if (eq? password master-password)
    203           history
    204           (bad-password self password))))))
    205 
    206 ;;;------------------------------------------
    207 ;; bank-account implementation
    208 ;;-------------------------------------------
    209 
    210 (define (make-account a-name an-age a-ssn a-pin initial-balance master-password)
    211   (object-with-ancestors
    212     ((customer (make-person a-name an-age a-ssn a-pin))
    213      (account (make-account-history initial-balance a-pin master-password)))
    214     ((get-pin self password)
    215       (if (eq? password master-password)
    216         a-pin
    217         (bad-password self password)))
    218     ((get-account-history self password)
    219       (operate-as account get-account-history self password))
    220     ;; our bank is very conservative...
    221     ((bad-password self bogus-passwd)
    222       (format #t "~%CALL THE POLICE!!~%"))
    223     ;; protect the customer as well
    224     ((ssn self password)
    225       (operate-as customer ssn self password))
    226     ((print-obj self port)
    227       (format port "#<Bank-Customer ~a>~%" (name self)))))
    228 
    229 ;;; eof yasos-examples.scm
    230 
    231 ;;;============
    232 ;;; file: yasos-test.scm
    233 ;;;============
    234 
    235 (declare (uses yasos-examples))
    236 (define main
    237   (lambda ()
    238     (let
    239       ((p2 (make-point 1 2))
    240        (p3 (make-point-3d 4 5 6))
    241        (fred  (make-person  "Fred"  19 "573-19-4279" 'FadeCafe))
    242        (sally (make-account "Sally" 26 "629-26-9742" 'FeedBabe 263 'bank-password)))
    243       (printf "(size-obj p2) => ~a (size-obj p3) => ~a~%" (size-obj p2) (size-obj p3))
    244       (print-obj 'mist #t)
    245       (print-obj p2 #t)
    246       (printf "(point? p2) => ~A (point-3d? p2) => ~A~%" (point? p2) (point-3d? p2))
    247       (print-obj p3 #t)
    248       (printf "(point? p3) => ~A (point-3d? p3) => ~A~%" (point? p3) (point-3d? p3))
    249       (print-obj fred #t)
    250       (printf "Fred's ssn: ~a~%" (ssn fred 'FadeCafe))
    251       (printf "Fred: person? ~a bank-account? ~a~%" (person? fred) (bank-account? fred))
    252       (print-obj sally #t)
    253       (printf "Sally's  ssn: ~a~%" (ssn sally 'FeedBabe))
    254       (printf "Sally: person? ~a bank-account? ~a~%" (person? sally) (bank-account? sally))
    255       (current-balance sally 'FeedBabe)
    256       (add sally 200)
    257       (add sally 300)
    258       (withdraw sally 400 'FeedBabe)
    259       (printf "Account history of Sally: ~a~%" (get-account-history sally 'bank-password))
    260       (withdraw sally 150 (get-pin sally 'bank-password))
    261       (printf "Account history of Sally: ~a~%" (get-account-history sally 'bank-password))
    262       (printf "Bad password for Fred:~%")
    263       (ssn fred 'bogus)
    264       (printf "Bad password for Sally:")
    265       (ssn sally 'bogus)
    266       (void)
    267 ) ) )   
    268 (main)
    269 
    270 ;;; eof yasos-test.scm
     218        (operate-as account get-account-history self password))
     219      ;; our bank is very conservative...
     220      ((bad-password self bogus-passwd)
     221        (format #t "~%CALL THE POLICE!!~%"))
     222      ;; protect the customer as well
     223      ((ssn self password)
     224        (operate-as customer ssn self password))
     225      ((print-obj self port)
     226        (format port "#<Bank-Customer ~a>~%" (name self)))))
     227 
     228  ;;; eof yasos-examples.scm
     229 
     230  ;;;============
     231  ;;; file: yasos-test.scm
     232  ;;;============
     233 
     234  (declare (uses yasos-examples))
     235  (define main
     236    (lambda ()
     237      (let
     238        ((p2 (make-point 1 2))
     239         (p3 (make-point-3d 4 5 6))
     240         (fred  (make-person  "Fred"  19 "573-19-4279" 'FadeCafe))
     241         (sally (make-account "Sally" 26 "629-26-9742" 'FeedBabe 263 'bank-password)))
     242        (printf "(size-obj p2) => ~a (size-obj p3) => ~a~%" (size-obj p2) (size-obj p3))
     243        (print-obj 'mist #t)
     244        (print-obj p2 #t)
     245        (printf "(point? p2) => ~A (point-3d? p2) => ~A~%" (point? p2) (point-3d? p2))
     246        (print-obj p3 #t)
     247        (printf "(point? p3) => ~A (point-3d? p3) => ~A~%" (point? p3) (point-3d? p3))
     248        (print-obj fred #t)
     249        (printf "Fred's ssn: ~a~%" (ssn fred 'FadeCafe))
     250        (printf "Fred: person? ~a bank-account? ~a~%" (person? fred) (bank-account? fred))
     251        (print-obj sally #t)
     252        (printf "Sally's  ssn: ~a~%" (ssn sally 'FeedBabe))
     253        (printf "Sally: person? ~a bank-account? ~a~%" (person? sally) (bank-account? sally))
     254        (current-balance sally 'FeedBabe)
     255        (add sally 200)
     256        (add sally 300)
     257        (withdraw sally 400 'FeedBabe)
     258        (printf "Account history of Sally: ~a~%" (get-account-history sally 'bank-password))
     259        (withdraw sally 150 (get-pin sally 'bank-password))
     260        (printf "Account history of Sally: ~a~%" (get-account-history sally 'bank-password))
     261        (printf "Bad password for Fred:~%")
     262        (ssn fred 'bogus)
     263        (printf "Bad password for Sally:")
     264        (ssn sally 'bogus)
     265        (void)
     266  ) ) )   
     267  (main)
     268 
     269  ;;; eof yasos-test.scm
     270
    271271License:
    272272
Note: See TracChangeset for help on using the changeset viewer.