164 lines
5.9 KiB
Racket
164 lines
5.9 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 ★/t))
|
|
#:with QuoteInterest (Observe (QuoteT ★/t ★/t)))
|
|
|
|
(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 ★/t))
|
|
#:with SplitInterest (Observe (SplitProposalT ★/t ★/t ★/t ★/t)))
|
|
|
|
(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 oid delivery-date)
|
|
#:type-constructor OrderT
|
|
#:with Order (OrderT String Int (Maybe OrderId) (Maybe DeliveryDate))
|
|
#:with OrderRequest (Observe (OrderT String Int ★/t ★/t))
|
|
#:with OrderInterest (Observe (OrderT ★/t ★/t ★/t ★/t)))
|
|
|
|
(define-type-alias ds-type
|
|
(U ;; quotes
|
|
Quote
|
|
QuoteRequest
|
|
(Observe QuoteInterest)
|
|
;; splits
|
|
SplitProposal
|
|
SplitRequest
|
|
(Observe SplitInterest)
|
|
;; orders
|
|
Order
|
|
OrderRequest
|
|
(Observe OrderInterest)))
|
|
|
|
(define-type-alias seller-role
|
|
(Role (seller)
|
|
(During (Observe (QuoteT String ★/t))
|
|
(Shares (QuoteT String QuoteAnswer)))
|
|
#;(Reacts (Asserted (Observe (QuoteT String ★/t)))
|
|
(Role (_)
|
|
;; QuoteAnswer was originally, erroneously, Int
|
|
(Shares (QuoteT String QuoteAnswer))))))
|
|
|
|
(run-ground-dataspace ds-type
|
|
|
|
;; seller
|
|
(spawn ds-type
|
|
(lift+define-role seller-impl
|
|
(start-facet _ ;; #:implements seller-role
|
|
(field [book (Tuple String Int) (tuple "Catch 22" 22)]
|
|
[next-order-id Int 10001483])
|
|
(on (asserted (observe (quote (bind title String) discard)))
|
|
(start-facet x
|
|
(on (retracted (observe (quote title discard)))
|
|
(stop x))
|
|
(define answer
|
|
(match title
|
|
["Catch 22"
|
|
(price 22)]
|
|
[_
|
|
(out-of-stock)]))
|
|
(assert (quote title answer))))
|
|
(on (asserted (observe (order (bind title String) (bind offer Int) discard discard)))
|
|
(start-facet x
|
|
(on (retracted (observe (order title offer discard discard)))
|
|
(stop x))
|
|
(let ([asking-price 22])
|
|
(if (and (equal? title "Catch 22") (>= offer asking-price))
|
|
(let ([id (ref next-order-id)])
|
|
(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
|
|
(lift+define-role buyer-a-impl
|
|
(start-facet buyer
|
|
(field [title String "Catch 22"]
|
|
[budget Int 1000])
|
|
(on (asserted (quote (ref title) (bind answer QuoteAnswer)))
|
|
(match answer
|
|
[(out-of-stock)
|
|
(stop buyer)]
|
|
[(price (bind amount Int))
|
|
(start-facet negotiation
|
|
(field [contribution Int (/ amount 2)])
|
|
(on (asserted (split-proposal (ref title) amount (ref contribution) (bind accept? Bool)))
|
|
(if accept?
|
|
(stop buyer)
|
|
(if (> (ref contribution) (- amount 5))
|
|
(stop negotiation (displayln "negotiation failed"))
|
|
(set! contribution
|
|
(+ (ref contribution) (/ (- amount (ref contribution)) 2)))))))])))))
|
|
|
|
;; buyer B
|
|
(spawn ds-type
|
|
(lift+define-role buyer-b-impl
|
|
(start-facet buyer-b
|
|
(field [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))
|
|
(start-facet decline
|
|
(assert (split-proposal title price their-contribution #f))
|
|
(on (retracted (observe (split-proposal title price their-contribution discard)))
|
|
(stop decline)))]
|
|
[#t
|
|
(start-facet accept
|
|
(assert (split-proposal title price their-contribution #t))
|
|
(on (retracted (observe (split-proposal title price their-contribution discard)))
|
|
(stop accept))
|
|
(on start
|
|
(spawn ds-type
|
|
(start-facet purchase
|
|
(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))]
|
|
[discard
|
|
(begin (displayln "Order Rejected")
|
|
(stop purchase))]))))))]))))))
|
|
)
|
|
|
|
(module+ test
|
|
(check-simulates seller-impl seller-impl)
|
|
;; found a bug in spec, see seller-role above
|
|
(check-simulates seller-impl seller-role)
|
|
(check-simulates buyer-a-impl buyer-a-impl)
|
|
(check-simulates buyer-b-impl buyer-b-impl))
|