; INSTRUMENT
(define (an-instrument type value)
(let (
(owner #f)
)
;REQUESTS
(define (the-instrument op)
(cond ((eq? op 'set-owner) (lambda (o) (set-owner o)))
((eq? op 'type) (lambda () type)) ;Returns the type
((eq? op 'owner) (lambda () owner));Returns the owner
((eq? op 'value) (lambda () value));Returns the value
(else (error "the-instrument - operation not defined: " op))
)
)
;INTERNAL METHODS
;Set the instruments owner
(define (set-owner o)
(begin
(set! owner o)
#t)
)
;Validates the parameters to the-instrument object
(define (instrument? t v)
;Validate the type
(define (type? t)
(cond
((not (symbol? t)) (error "an-instrument - type not a symbol: " t))
(else #t)
)
)
;Validate the value
(define (value? v)
(cond
((not (number? v)) (error "an-instrument - not a value: " v))
((not (> v 0)) (error "an-instrument - not a positive value:" v))
((not (real? v)) (error "an-instrument - not a real value: " v))
)
)
(if (and (value? v) (type? t)) #t)
)
(begin
(instrument? type value)
the-instrument
)
)
)
;GLOBAL PROCEDURES
;set the owner
(define (set-owner i o)
((i 'set-owner) o)
)
;get the instrument type
(define (type i)
((i 'type))
)
;get the instrument owner
(define (owner i)
((i 'owner))
)
;get the instrument value
(define (value i)
((i 'value))
)
; PLAYER
(define (a-player)
(let
(
(the-collection nil)
)
;REQUESTS
(define (the-player op)
(cond ((eq? 'acquire op) (lambda (i) (acquire the-collection i)))
((eq? 'remove op) (lambda (i) (remove i)))
((eq? 'collection op) (lambda (o) (current-collection the-collection o)))
(else (error "the-player - operation not defined: " op))
)
)
;INTERNAL METHODS
;Add instrument to the players collection - the-collection
(define (acquire collection instrument)
(cond
((null? collection) (begin
(set! the-collection (cons instrument the-collection)))
(if (eq? (owner instrument) #f) (set-owner instrument the-player))
#t)
((eq? (car collection) instrument) #f)
(else (acquire (cdr collection) instrument))
)
)
;Remove instrument from the-collection
(define (remove instrument)
(define (remove-item collection instrument)
(cond
((null? collection) nil)
((not (eq? (car collection) instrument)) (cons (car collection) (remove-item (cdr collection) instrument)))
(else (remove-item (cdr collection) instrument))
)
)
(if (equal? the-collection (remove-item the-collection instrument)) nil
(begin
(set! the-collection (remove-item the-collection instrument))
instrument)
)
)
;Current collection
(define (current-collection collection the-owner)
(cond
((null? collection) nil)
((eq? (owner (car collection)) the-owner) (cons (car collection) (current-collection (cdr collection) the-owner)))
(else (current-collection (cdr collection) the-owner))
))
the-player
)
)
;GLOBAL PROCEDURES
;Remove an instrument from a player's collection
(define (remove player instrument)
((player 'remove) instrument)
)
;Return the items in the player's collection owned by owner
(define (collection player owner)
((player 'collection) owner)
)
;Add an item to a players collection
(define (acquire object instrument)
((object 'acquire) instrument)
)
;LIBRARY
(define (a-library)
(let (
(the-stock nil) ;Unloaned items
(the-loans nil) ;Loaned items
)
(define (the-library op)
(cond ((eq? op 'acquire) (lambda (i) (acquire-instrument i)))
((eq? op 'lend) (lambda (t p) (lend-instrument t p)))
((eq? op 'return) (lambda (i) (return-instrument i)))
(else (error "the-library - operation not defined: " op))
)
)
(define (acquire-instrument instrument)
;Check the instrument isnt owned already
(define (check-for-owner i)
(if (eq? (owner i) #f)
(begin
(set-owner i the-library) ;set the owner to be this library
(add-to-stock i)
#t)
#f)
)
;Add the instrument to the stock
(define (add-to-stock i)
(set! the-stock (cons i the-stock))
)
(check-for-owner instrument)
)
(define (lend-instrument search-type player) ;lend the instrument, update stock, update loans
(define (assign-item search-type player stock)
(cond
((null? stock) nil)
((eq? (type (car stock)) search-type)
(begin
(update-stock (car stock)) ;(update-stock (the instrument to loan)
(acquire player (car stock)) ; call the players aquire (the instrument)
(set-loan player (car stock)) ; include the instrument and the player in the-loans
(cdar the-loans) ; the newly loaned instrument
))
(else (assign-item search-type player (cdr stock)))
)
)
(define (set-loan player item);add the pair (player . instrument) to the-loans
(set! the-loans (cons (cons player item) the-loans))
)
(define (update-stock instrument) ;remove the item from the the-loans
(define (remove-stock stock instrument);remove the item from the-stock variable
(cond
((null? stock) nil)
((not (eq? (car stock) instrument)) (cons (car stock) (remove-stock (cdr stock) instrument)))
(else (remove-stock (cdr stock) instrument))
)
)
(set! the-stock (remove-stock the-stock instrument)) ;set the stock to reflect the item has been removed
)
(assign-item search-type player the-stock) ;lend-item initial procedure
)
(define (return-instrument instrument)
(define (update-loans loans instrument);remove the requested loan from the-loans
(cond
((null? loans) nil)
((not (eq? (cdr (car loans)) instrument)) (cons (car loans) (update-loans (cdr loans) instrument)))
(else (update-loans (cdr loans) instrument))
))
(define (find-borrower loans instrument);find the borrower of the instrument that is being returned
(cond
((null? loans) nil)
((eq? (cdr (car loans)) instrument) (caar loans) )
(else (find-borrower (cdr loans) instrument))
))
(cond ;body of return-instrument
((equal? (update-loans the-loans instrument) the-loans) #f)
((not(eq? (owner instrument) the-library)) #f)
(else
(begin
(let
((borrower (find-borrower the-loans instrument)) )
(remove (find-borrower the-loans instrument) instrument)
(set! the-loans (update-loans the-loans instrument))
(set-owner instrument #f)
(acquire-instrument instrument)
borrower))))
)
the-library
)
)
;Lend any object of the type to the player
(define (lend object type player)
((object 'lend) type player)
)
;Return the instrument from the correct owner without specifying
(define (return object instrument)
((object 'return) instrument)
)
;HIRE SHOP
(define (a-shop)
(let
(
(shop-library (a-library)) ;inherit procedures from a-library
(the-accounts nil) ;customer accounts for lending
)
(define (the-shop op)
(cond ((eq? op 'acquire) (lambda (i) (acquire-shop i)))
((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
((eq? op 'return) (lambda (i) (return-shop i)))
((eq? op 'owes) (lambda (p) (owes p))) ;return the account balance
((eq? op 'pay) (lambda (a p) (pay a p)));add the amount specified to the correct account
(else (error "the-shop - operation not defined: " op))
)
)
;Same functionality as library acquire
(define (acquire-shop i)
(if (eq? (owner i) #f)
(begin
(acquire shop-library i)
(set-owner i the-shop)
#t)
#f)
)
;sets the owed money to 10% of the instruments value
(define (add-loan loan type player)
(cond
((null? loan) #f)
(else
(begin
(set-cdr! (check-account player) (+ (* (value loan) 0.1) (cdr (check-account player))))
(+ (* (value loan) 0.1))
))))
(define (lend-shop type player)
(lend shop-library type player)
)
;Changes the owner to the shop-library and returns the instrument
(define (return-shop i)
(begin
(set-owner i shop-library)
(return shop-library i))
)
(define (check-account player)
;Does the account exist in accounts?
(define (account-exists? player accounts)
(cond
((null? accounts) (new-account player) )
((eq? (caar accounts) player) (car accounts))
(else (account-exists? player (cdr accounts)))
))
;If not, add a new account
(define (new-account player)
(begin
(set! the-accounts (cons (cons player 0) the-accounts))
(account-exists? player the-accounts) ;The account does exist now. Check it.
))
(account-exists? player the-accounts)
)
(define (owes player)
(cdr (check-account player))
)
;Take away the amount payed from the owed value
(define (pay amount player)
(cond
((and (number? amount) (< 0 amount));Validate
(begin
(set-cdr! (check-account player) (- (cdr (check-account player)) amount)) ;CDR of the account is the amount owed
(cdr (check-account player))))
(else (error "the-shop - not a valid amount to pay: " amount))
))
the-shop
)
)
;How much a player owes - 0 by default
(define (owes shop player)
((shop 'owes) player)
)
;Add money to an account - everyone can deposit money in an account,
(define (pay shop amount player)
((shop 'pay) amount player)
)