1 ;;; 8sync --- Asynchronous programming for Guile
2 ;;; Copyright (C) 2016 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;; This file is part of 8sync.
6 ;;; 8sync is free software: you can redistribute it and/or modify it
7 ;;; under the terms of the GNU Lesser General Public License as
8 ;;; published by the Free Software Foundation, either version 3 of the
9 ;;; License, or (at your option) any later version.
11 ;;; 8sync is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU Lesser General Public License for more details.
16 ;;; You should have received a copy of the GNU Lesser General Public
17 ;;; License along with 8sync. If not, see <http://www.gnu.org/licenses/>.
19 ;; Puppet show simulator.
21 (use-modules (8sync agenda)
22 (8sync systems actors)
27 (set! *random-state* (random-state-from-platform))
28 (define (random-choice lst)
29 (list-ref lst (random (length lst))))
33 '("Henry" "Harmony" "Rolf"))
35 (define (student-name-generator)
36 ;; a hashmap of student names with their current count
37 (define student-count (make-hash-table))
39 (let* ((student (random-choice student-names))
40 (current-number (hash-ref student-count student 1)))
41 (hash-set! student-count student (1+ current-number))
42 (format #f "~a-~a" student current-number))))
45 (define-class <student> (<actor>)
46 (name #:init-keyword #:name)
48 #:accessor student-dead)
53 (lambda (actor message)
54 "Go bother a professor"
55 (while (not (student-dead actor))
56 (format #t "~a: Bother bother bother!\n"
57 (actor-id-actor actor))
59 actor (message-ref message 'target)
61 #:noise "Bother bother bother!\n"))))
63 (be-lambda-consvardraed
64 (lambda (actor message)
65 "This kills the student."
66 (format #t "~a says: AAAAAAAHHHH!!! I'm dead!\n"
67 (actor-id-actor actor))
68 (set! (student-dead actor) #t))))))
71 '("Hey!" "Stop that!" "Oof!"))
73 (define (professor-be-bothered actor message)
74 (define whos-bothering (professor-bothered-by actor))
76 (hash-set! whos-bothering (message-from message) #t)
79 (display (string-append (random-choice complaints)))
81 ;; More than one student is bothering us, lose our temper
82 (if (> (hash-count (const #t) whos-bothering)
85 (format #t "~s: LAMBDA CONSVARDRA!\n"
91 'be-lambda-consvardraed)
92 ;; Remove student from bothering list
93 (hash-remove! whos-bothering student))
95 ;; Otherwise, remove them from the list and carry on
96 (hash-remove! whos-bothering (message-from message))))
98 (define-class <professor> (<actor>)
99 ;; This value checks whether any other actor is currently
100 ;; bothering this same character.
101 ;; We'll use a hash table as a fake set.
102 (bothered-by #:init-thunk make-hash-table
103 #:getter professor-bothered-by)
106 (make-action-dispatch
107 (be-bothered professor-be-bothered))))
109 (define num-students 10)
112 (define agenda (make-agenda))
113 (define hive (make-hive))
114 (define professor (hive-create-actor hive <professor>))
115 (define namegen (student-name-generator))
119 (hive-create-actor* hive <student>
121 (iota num-students)))
123 ;; Bootstrap each student into bothering-professor mode.
124 (define start-bothering-tasks
127 (hive-bootstrap-message hive student 'bother-professor
131 (ez-run-hive hive start-bothering-tasks))