Want more features on Pastebin? Sign Up, it's FREE!
Guest

Simown

By: a guest on Aug 15th, 2010  |  syntax: Scheme  |  size: 10.04 KB  |  views: 34  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. ;       INSTRUMENT
  2.  
  3. (define (an-instrument type value)
  4.   (let (
  5.         (owner #f)
  6.         )
  7.  
  8.     ;REQUESTS
  9.     (define (the-instrument op)
  10.       (cond ((eq? op 'set-owner) (lambda (o) (set-owner o)))
  11.             ((eq? op 'type)      (lambda () type)) ;Returns the type
  12.             ((eq? op 'owner)     (lambda () owner));Returns the owner
  13.             ((eq? op 'value)     (lambda () value));Returns the value
  14.             (else (error "the-instrument - operation not defined: " op))
  15.          )
  16.       )
  17.    
  18.   ;INTERNAL METHODS
  19.    
  20.   ;Set the instruments owner  
  21.     (define (set-owner o)
  22.     (begin
  23.       (set! owner o)
  24.       #t)
  25.     )
  26.    
  27.      ;Validates the parameters to the-instrument object
  28.     (define (instrument? t v)
  29.     ;Validate the type
  30.     (define (type? t)
  31.       (cond
  32.             ((not (symbol? t)) (error "an-instrument - type not a symbol: " t))
  33.             (else #t)
  34.             )
  35.       )
  36.     ;Validate the value
  37.     (define (value? v)
  38.     (cond
  39.       ((not (number?  v)) (error "an-instrument - not a value: " v))
  40.       ((not (> v 0)) (error "an-instrument - not a positive value:" v))
  41.       ((not (real? v)) (error "an-instrument - not a real value: " v))
  42.       )
  43.   )
  44.    
  45.       (if (and (value? v) (type? t)) #t)
  46.      
  47.       )  
  48.      
  49.   (begin
  50.   (instrument? type value)
  51.    the-instrument
  52.                  )            
  53.               )
  54.             )
  55.  
  56. ;GLOBAL PROCEDURES
  57. ;set the owner
  58. (define (set-owner i o)
  59.   ((i 'set-owner) o)
  60.   )
  61. ;get the instrument type
  62. (define (type i)
  63.   ((i 'type))
  64.   )
  65. ;get the instrument owner
  66. (define (owner i)
  67.   ((i 'owner))
  68.   )
  69. ;get the instrument value
  70. (define (value i)
  71.   ((i 'value))
  72.   )
  73.  
  74. ; PLAYER
  75.  
  76. (define (a-player)
  77.   (let
  78.       (
  79.        (the-collection nil)
  80.        )
  81.     ;REQUESTS
  82.     (define (the-player op)
  83.       (cond ((eq? 'acquire op)     (lambda (i) (acquire the-collection i)))
  84.             ((eq? 'remove op)      (lambda (i) (remove i)))
  85.             ((eq? 'collection op)  (lambda (o) (current-collection the-collection o)))
  86.             (else (error "the-player - operation not defined: " op))
  87.             )
  88.       )
  89.    
  90. ;INTERNAL METHODS
  91.      
  92.  ;Add instrument to the players collection - the-collection
  93.   (define (acquire collection instrument)
  94.      (cond
  95.       ((null? collection) (begin
  96.                             (set! the-collection (cons instrument the-collection)))
  97.                             (if (eq? (owner instrument) #f) (set-owner instrument the-player))
  98.                             #t)
  99.       ((eq? (car collection) instrument) #f)
  100.       (else (acquire (cdr collection) instrument))
  101.       )
  102.     )
  103.    
  104. ;Remove instrument from the-collection
  105. (define (remove instrument)
  106.  
  107. (define (remove-item collection instrument)
  108.   (cond
  109.     ((null? collection) nil)
  110.     ((not (eq? (car collection) instrument)) (cons (car collection) (remove-item (cdr collection) instrument)))
  111.     (else (remove-item (cdr collection) instrument))
  112.   )
  113. )
  114.  
  115. (if (equal? the-collection (remove-item the-collection instrument)) nil
  116. (begin
  117.   (set! the-collection (remove-item the-collection instrument))
  118.   instrument)
  119.  
  120.       )
  121.   )
  122.  
  123. ;Current collection
  124. (define (current-collection collection the-owner)
  125. (cond
  126.   ((null? collection) nil)
  127.   ((eq? (owner (car collection)) the-owner) (cons (car collection) (current-collection (cdr collection) the-owner)))
  128.   (else (current-collection (cdr collection) the-owner))
  129. ))
  130.      
  131.  the-player
  132.    
  133.    
  134.     )
  135. )
  136.  
  137. ;GLOBAL PROCEDURES
  138.  
  139. ;Remove an instrument from a player's collection
  140. (define (remove player instrument)
  141.   ((player 'remove) instrument)
  142. )
  143.  
  144. ;Return the items in the player's collection owned by owner
  145. (define (collection player owner)
  146.   ((player 'collection) owner)
  147.   )
  148.  
  149. ;Add an item to a players collection
  150. (define (acquire object instrument)
  151. ((object 'acquire) instrument)
  152.   )
  153.  
  154.  
  155. ;LIBRARY
  156.  
  157. (define (a-library)
  158.   (let (
  159.         (the-stock nil) ;Unloaned items
  160.         (the-loans nil) ;Loaned items
  161.        )
  162. (define (the-library op)
  163.   (cond ((eq? op 'acquire)    (lambda (i)   (acquire-instrument i)))
  164.         ((eq? op 'lend)       (lambda (t p) (lend-instrument t p)))
  165.         ((eq? op 'return)     (lambda (i)   (return-instrument i)))
  166.         (else (error "the-library - operation not defined: " op))
  167.         )
  168.   )
  169.    
  170.   (define (acquire-instrument instrument)
  171.    
  172.   ;Check the instrument isnt owned already
  173.   (define (check-for-owner i)
  174.   (if (eq? (owner i) #f)
  175.       (begin
  176.         (set-owner i the-library) ;set the owner to be this library
  177.         (add-to-stock i)
  178.         #t)
  179.   #f)
  180.   )
  181.   ;Add the instrument to the stock  
  182.   (define (add-to-stock i)  
  183.     (set! the-stock (cons i the-stock))
  184.     )
  185.    (check-for-owner instrument)
  186.   )
  187.    
  188.    
  189. (define (lend-instrument search-type player) ;lend the instrument, update stock, update loans
  190.    
  191.   (define (assign-item search-type player stock)  
  192.     (cond
  193.       ((null? stock) nil)
  194.       ((eq? (type (car stock)) search-type)
  195.        (begin
  196.        (update-stock (car stock)) ;(update-stock (the instrument to loan)
  197.        (acquire player (car stock)) ; call the players aquire (the instrument)
  198.        (set-loan player (car stock)) ; include the instrument and the player in the-loans
  199.        (cdar the-loans) ; the newly loaned instrument
  200.        ))
  201.       (else (assign-item search-type player (cdr stock)))
  202.       )
  203.     )
  204.    
  205.   (define (set-loan player item);add the pair (player . instrument) to the-loans
  206.   (set! the-loans (cons (cons player item) the-loans))
  207.   )
  208.    
  209. (define (update-stock instrument) ;remove the item from the the-loans
  210.  
  211. (define (remove-stock stock instrument);remove the item from the-stock variable
  212.   (cond
  213.     ((null? stock) nil)
  214.     ((not (eq? (car stock) instrument)) (cons (car stock) (remove-stock (cdr stock) instrument)))
  215.     (else (remove-stock (cdr stock) instrument))
  216.   )
  217. )
  218.  
  219. (set! the-stock (remove-stock the-stock instrument)) ;set the stock to reflect the item has been removed
  220.  
  221. )
  222.        
  223.   (assign-item search-type player the-stock) ;lend-item initial procedure
  224. )
  225.    
  226.    
  227. (define (return-instrument instrument)
  228.  
  229. (define (update-loans loans instrument);remove the requested loan from the-loans
  230.   (cond
  231.     ((null? loans) nil)
  232.     ((not (eq? (cdr (car loans)) instrument)) (cons (car loans) (update-loans (cdr loans) instrument)))
  233.     (else (update-loans (cdr loans) instrument))
  234. ))
  235.  
  236. (define (find-borrower loans instrument);find the borrower of the instrument that is being returned
  237.   (cond
  238.    ((null? loans) nil)
  239.    ((eq? (cdr (car loans)) instrument) (caar loans) )
  240.    (else (find-borrower (cdr loans) instrument))
  241.    ))
  242.  
  243. (cond                                                             ;body of return-instrument
  244.      ((equal? (update-loans the-loans instrument) the-loans) #f)
  245.      ((not(eq? (owner instrument) the-library)) #f)
  246. (else    
  247. (begin
  248. (let
  249.     ((borrower (find-borrower the-loans instrument)) )
  250. (remove (find-borrower the-loans instrument) instrument)
  251. (set! the-loans (update-loans the-loans instrument))
  252. (set-owner instrument #f)
  253. (acquire-instrument instrument)
  254.  borrower))))
  255.    
  256.  )  
  257.   the-library
  258.   )
  259. )  
  260.  
  261. ;Lend any object of the type to the player  
  262. (define (lend object type player)
  263.   ((object 'lend) type player)
  264.  )
  265.  
  266. ;Return the instrument from the correct owner without specifying
  267. (define (return object instrument)
  268.  ((object 'return) instrument)
  269. )
  270.  
  271.  
  272.  
  273. ;HIRE SHOP
  274.  
  275. (define (a-shop)
  276. (let
  277.      (
  278.      (shop-library (a-library)) ;inherit procedures from a-library
  279.      (the-accounts nil) ;customer accounts for lending
  280.      )
  281.   (define (the-shop op)
  282.   (cond ((eq? op 'acquire)    (lambda (i)   (acquire-shop i)))
  283.         ((eq? op 'lend)       (lambda (t p) (add-loan (lend-shop t p) t p))) ;lend the item and add the loan to the players account
  284.         ((eq? op 'return)     (lambda (i)   (return-shop i)))
  285.         ((eq? op 'owes)       (lambda (p)   (owes p))) ;return the account balance
  286.         ((eq? op 'pay)        (lambda (a p) (pay a p)));add the amount specified to the correct account
  287.         (else (error "the-shop - operation not defined: " op))
  288.         )
  289.     )
  290. ;Same functionality as library acquire  
  291. (define (acquire-shop i)
  292.   (if (eq? (owner i) #f)
  293.   (begin
  294.     (acquire shop-library i)
  295.     (set-owner i the-shop)
  296.     #t)
  297.     #f)
  298.   )
  299. ;sets the owed money to 10% of the instruments value  
  300. (define (add-loan loan type player)
  301.  (cond
  302.    ((null? loan) #f)
  303.    (else
  304.    (begin
  305.    (set-cdr! (check-account player) (+ (* (value loan) 0.1) (cdr (check-account player))))
  306.    (+ (* (value loan) 0.1))
  307.    ))))
  308.  
  309.  (define (lend-shop type player)
  310.    (lend shop-library type player)
  311.    )
  312.  
  313.  ;Changes the owner to the shop-library and returns the instrument
  314.  (define (return-shop i)
  315.  (begin
  316.  (set-owner i shop-library)  
  317.  (return shop-library i))
  318.    )
  319.  
  320. (define (check-account player)
  321. ;Does the account exist in accounts?  
  322.  (define (account-exists? player accounts)
  323.   (cond
  324.    ((null? accounts) (new-account player) )
  325.    ((eq? (caar accounts) player) (car accounts))
  326.    (else (account-exists? player (cdr accounts)))
  327.  ))
  328. ;If not, add a new account  
  329.  (define (new-account player)
  330.  (begin  
  331.  (set! the-accounts (cons (cons player 0) the-accounts))
  332.  (account-exists? player the-accounts) ;The account does exist now. Check it.
  333.  ))
  334.  
  335.  (account-exists? player the-accounts)
  336. )
  337.          
  338.  
  339.  
  340. (define (owes player)
  341.  (cdr (check-account player))
  342. )
  343.  
  344. ;Take away the amount payed from the owed value  
  345. (define (pay amount player)
  346. (cond
  347. ((and (number? amount) (< 0 amount));Validate
  348. (begin  
  349. (set-cdr! (check-account player) (- (cdr (check-account player)) amount)) ;CDR of the account is the amount owed
  350. (cdr (check-account player))))
  351. (else (error "the-shop - not a valid amount to pay: " amount))
  352. ))
  353.                                
  354.   the-shop
  355.   )
  356.          
  357. )
  358.  
  359. ;How much a player owes - 0 by default
  360. (define (owes shop player)
  361.   ((shop 'owes) player)
  362.   )
  363. ;Add money to an account - everyone can deposit money in an account,
  364. (define (pay shop amount player)
  365.   ((shop 'pay) amount player)
  366. )
clone this paste RAW Paste Data