From dbbcc6458c25b95e2813c2efa5f1e4c10dd78f65 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Wed, 18 Sep 2019 21:30:15 +0200 Subject: [PATCH] Playing with using actors for IF. --- actors.scm | 16 ++++- island.scm | 145 +++++++++++++++++++++++++++++++++++++++++ testing_counter.scm | 2 +- testing_factorial1.scm | 2 +- testing_factorial2.scm | 2 +- testing_factorial3.scm | 2 +- 6 files changed, 163 insertions(+), 6 deletions(-) create mode 100644 island.scm diff --git a/actors.scm b/actors.scm index 884920d..fc266a3 100644 --- a/actors.scm +++ b/actors.scm @@ -4,7 +4,9 @@ send-message run send-and-run - trace-enabled) + restart + enable-trace + disable-trace) (import scheme (chicken base) @@ -13,6 +15,12 @@ (define trace-enabled #f) ;used for debugging + (define (enable-trace) + (set! trace-enabled #t)) + + (define (disable-trace) + (set! trace-enabled #f)) + ;;; ;;; Actor creation @@ -139,4 +147,8 @@ (define (send-and-run actor . message) (apply send-message (cons actor message)) - (run))) + (run)) + + (define (restart) + (set! message-queue (make-fifo)) + (set! actor-table (make-hash-table)))) diff --git a/island.scm b/island.scm new file mode 100644 index 0000000..dbbd13d --- /dev/null +++ b/island.scm @@ -0,0 +1,145 @@ +(import scheme + (chicken base) + (chicken string) + (chicken io) + srfi-1 srfi-13 + matchable + actors) + +;; (enable-trace) +(disable-trace) +(restart) + +(define (parse-input string) + (map string->symbol (string-tokenize string))) + +(define ((player-beh loc) self . message) + (match message + (('init) + (send-message self 'query') + 'sleep) + (('print string) + (print string) + (send-message self 'query) + 'sleep) + (('query) + (print* "==> ") + (let ((new-message (parse-input (read-line)))) + (apply send-message (cons self new-message))) + 'sleep) + ((or ('quit) ('q)) + (print "Bye!") + 'sleep) + ;; Internal messages + (('move-to new-loc) + (send-message self 'look) + (player-beh new-loc)) + (else + (apply send-message (cons loc (cons player message))) + 'sleep))) + +(define ((room-beh name description . exits) self . message) + (match message + (('add-exit exit) + (set! exits (cons exit exits)) + 'sleep) + ((or (player 'look) (player 'l) (player 'x)) + (let* ((room-desc (conc name "\n" description)) + (accumulator (make-actor (accumulate-descrs player + exits + (list room-desc))))) + (send-message accumulator 'init)) + 'sleep) + ((player x ...) + (let ((exit-tryer (make-actor + (try-exits player exits x)))) + (send-message exit-tryer 'init)) + 'sleep) + (else ;ignore unknown messages + 'sleep))) + +(define ((accumulate-descrs cust objects descrs) self . message) + (match message + (('init) + (if (null? objects) + (begin + (send-message cust 'print (string-intersperse (reverse descrs) "\n")) + 'done) + (begin + (send-message (car objects) self 'look) + (accumulate-descrs cust (cdr objects) descrs)))) + (('print descr) + (let ((new-descrs (cons descr descrs))) + (if (null? objects) + (begin + (send-message cust 'print (string-intersperse (reverse new-descrs) "\n")) + 'done) + (begin + (send-message (car objects) self 'look) + (accumulate-descrs cust (cdr objects) new-descrs))))))) + +(define ((try-exits player exits msg-to-send) self . message) + (match message + ((or ('init) ('no-match)) + (if (null? exits) + (begin + (send-message player 'print "I don't know how to do that.") + 'done) + (begin + (apply send-message (cons (car exits) (cons self msg-to-send))) + (try-exits player (cdr exits) msg-to-send)))) + (('move-to dest) + (apply send-message (cons player message)) + 'done))) + +(define ((exit-beh names description dest) self . message) + (if (not (= (length message) 2)) + 'sleep + (let ((cust (car message)) + (arg (cadr message))) + (cond + ((eq? arg 'look) + (send-message cust 'print description)) + ((memq arg names) + (send-message cust 'move-to dest)) + (else + (send-message cust 'no-match))) + 'sleep))) + +(define (make-room title desc) + (make-actor (room-beh title desc))) + +(define (add-exit from to names desc) + (send-message from 'add-exit (make-actor (exit-beh names desc to)))) + +(define shore + (make-room "Rocky shore at night" + (conc "You are standing on a rocky shore. Menacing waves crash periodically\n" + "against large bolders from all directions, occasionally spraying you\n" + "with salty ocean mist."))) + +(define ocean + (make-room "Cold ocean" + "You are now in the water.")) + +(define underwater + (make-room "Underwater" + "You are now swimming near the ocean floor.")) + +(add-exit shore ocean '(west w) + "A path leads west through the boulders down to the waves.") + +(add-exit ocean shore '(east e) + "The shore is to the east.") + +(add-exit ocean underwater '(down d) + "You can swim down here.") + +(add-exit underwater ocean '(up u) + "You can swim up from here.") + +(define player (make-actor-with-address 'player (player-beh shore))) + +(define (start) + (send-message player 'init) + (run)) diff --git a/testing_counter.scm b/testing_counter.scm index 0b25876..4ac1b79 100644 --- a/testing_counter.scm +++ b/testing_counter.scm @@ -1,6 +1,6 @@ (import actors) -(define trace-enabled #t) +(enable-trace) (define ((make-counter-behaviour value) self customer . args) (match args diff --git a/testing_factorial1.scm b/testing_factorial1.scm index 188dc32..aa3d1f0 100644 --- a/testing_factorial1.scm +++ b/testing_factorial1.scm @@ -1,6 +1,6 @@ (import actors) -(define trace-enabled #t) +(enable-trace) (define factorial (make-actor-with-address 'factorial diff --git a/testing_factorial2.scm b/testing_factorial2.scm index bba678e..958713d 100644 --- a/testing_factorial2.scm +++ b/testing_factorial2.scm @@ -1,6 +1,6 @@ (import actors) -(define trace-enabled #t) +(enable-trace) (define factorial (make-actor-with-address 'factorial diff --git a/testing_factorial3.scm b/testing_factorial3.scm index 29d3f85..e809c84 100644 --- a/testing_factorial3.scm +++ b/testing_factorial3.scm @@ -1,6 +1,6 @@ (import actors) -(define trace-enabled #t) +(enable-trace) (define factorial (make-actor-with-address -- 2.20.1