147 lines
6.3 KiB
Racket
147 lines
6.3 KiB
Racket
#lang typed/syndicate
|
|
|
|
;; Expected Output
|
|
;; Completed Order:
|
|
;; Catch 22
|
|
;; 10001483
|
|
;; March 9th
|
|
|
|
(define-constructor (price v)
|
|
#:type-constructor PriceT
|
|
#:with Price (PriceT Int))
|
|
|
|
(define-constructor (out-of-stock)
|
|
#:type-constructor OutOfStockT
|
|
#:with OutOfStock (OutOfStockT))
|
|
|
|
(define-type-alias QuoteAnswer
|
|
(U Price OutOfStock))
|
|
|
|
(define-constructor (quote title answer)
|
|
#:type-constructor QuoteT
|
|
#:with Quote (QuoteT String QuoteAnswer)
|
|
#:with QuoteRequest (Observe (QuoteT String ★))
|
|
#:with QuoteInterest (Observe (QuoteT ★ ★)))
|
|
|
|
(define-constructor (split-proposal title price contribution accepted)
|
|
#:type-constructor SplitProposalT
|
|
#:with SplitProposal (SplitProposalT String Int Int Bool)
|
|
#:with SplitRequest (Observe (SplitProposalT String Int Int ★))
|
|
#:with SplitInterest (Observe (SplitProposalT ★ ★ ★ ★)))
|
|
|
|
(define-constructor (order-id id)
|
|
#:type-constructor OrderIdT
|
|
#:with OrderId (OrderIdT Int))
|
|
|
|
(define-constructor (delivery-date date)
|
|
#:type-constructor DeliveryDateT
|
|
#:with DeliveryDate (DeliveryDateT String))
|
|
|
|
(define-type-alias (Maybe t)
|
|
(U t Bool))
|
|
|
|
(define-constructor (order title price id delivery-date)
|
|
#:type-constructor OrderT
|
|
#:with Order (OrderT String Int (Maybe OrderId) (Maybe DeliveryDate))
|
|
#:with OrderRequest (Observe (OrderT String Int ★ ★))
|
|
#:with OrderInterest (Observe (OrderT ★ ★ ★ ★)))
|
|
|
|
(define-type-alias ds-type
|
|
(U ;; quotes
|
|
Quote
|
|
QuoteRequest
|
|
(Observe QuoteInterest)
|
|
;; splits
|
|
SplitProposal
|
|
SplitRequest
|
|
(Observe SplitInterest)
|
|
;; orders
|
|
Order
|
|
OrderRequest
|
|
(Observe OrderInterest)))
|
|
|
|
(dataspace ds-type
|
|
|
|
;; seller
|
|
(spawn ds-type
|
|
(facet _
|
|
(fields [book (Tuple String Int) (tuple "Catch 22" 22)]
|
|
[next-order-id Int 10001483])
|
|
(on (asserted (observe (quote (bind title String) discard)))
|
|
(facet x
|
|
(fields)
|
|
(on (retracted (observe (quote title discard)))
|
|
(stop x (begin)))
|
|
(match title
|
|
["Catch 22"
|
|
(assert (quote title (price 22)))]
|
|
[discard
|
|
(assert (quote title (out-of-stock)))])))
|
|
(on (asserted (observe (order (bind title String) (bind offer Int) discard discard)))
|
|
(facet x
|
|
(fields)
|
|
(on (retracted (observe (order title offer discard discard)))
|
|
(stop x (begin)))
|
|
(let [asking-price 22]
|
|
(if (and (equal? title "Catch 22") (>= offer asking-price))
|
|
(let [id (ref next-order-id)]
|
|
(begin (set! next-order-id (+ 1 id))
|
|
(assert (order title offer (order-id id) (delivery-date "March 9th")))))
|
|
(assert (order title offer #f #f))))))))
|
|
|
|
;; buyer A
|
|
(spawn ds-type
|
|
(facet buyer
|
|
(fields [title String "Catch 22"]
|
|
[budget Int 1000])
|
|
(on (asserted (quote (ref title) (bind answer QuoteAnswer)))
|
|
(match answer
|
|
[(out-of-stock)
|
|
(stop buyer (begin))]
|
|
[(price (bind amount Int))
|
|
(facet negotiation
|
|
(fields [contribution Int (/ amount 2)])
|
|
(on (asserted (split-proposal (ref title) amount (ref contribution) (bind accept? Bool)))
|
|
(if accept?
|
|
(stop buyer (begin))
|
|
(if (> (ref contribution) (- amount 5))
|
|
(stop negotiation (displayln "negotiation failed"))
|
|
(set! contribution
|
|
(+ (ref contribution) (/ (- amount (ref contribution)) 2)))))))]))))
|
|
|
|
;; buyer B
|
|
(spawn ds-type
|
|
(facet buyer-b
|
|
(fields [funds Int 5])
|
|
(on (asserted (observe (split-proposal (bind title String) (bind price Int) (bind their-contribution Int) discard)))
|
|
(let [my-contribution (- price their-contribution)]
|
|
(cond
|
|
[(> my-contribution (ref funds))
|
|
(facet decline
|
|
(fields)
|
|
(assert (split-proposal title price their-contribution #f))
|
|
(on (retracted (observe (split-proposal title price their-contribution discard)))
|
|
(stop decline (begin))))]
|
|
[#t
|
|
(facet accept
|
|
(fields)
|
|
(assert (split-proposal title price their-contribution #t))
|
|
(on (retracted (observe (split-proposal title price their-contribution discard)))
|
|
(stop accept (begin)))
|
|
(on start
|
|
(spawn ds-type
|
|
(facet purchase
|
|
(fields)
|
|
(on (asserted (order title price (bind order-id? (Maybe OrderId)) (bind delivery-date? (Maybe DeliveryDate))))
|
|
(match (tuple order-id? delivery-date?)
|
|
[(tuple (order-id (bind id Int)) (delivery-date (bind date String)))
|
|
;; complete!
|
|
(begin (displayln "Completed Order:")
|
|
(displayln title)
|
|
(displayln id)
|
|
(displayln date)
|
|
(stop purchase (begin)))]
|
|
[discard
|
|
(begin (displayln "Order Rejected")
|
|
(stop purchase (begin)))]))))))])))))
|
|
) |