5 ;;; 8sync --- Asynchronous programming for Guile
6 ;;; Copyright © 2016, 2017 Christopher Allan Webber <cwebber@dustycloud.org>
8 ;;; This file is part of 8sync.
10 ;;; 8sync is free software: you can redistribute it and/or modify it
11 ;;; under the terms of the GNU Lesser General Public License as
12 ;;; published by the Free Software Foundation, either version 3 of the
13 ;;; License, or (at your option) any later version.
15 ;;; 8sync is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU Lesser General Public License for more details.
20 ;;; You should have received a copy of the GNU Lesser General Public
21 ;;; License along with 8sync. If not, see <http://www.gnu.org/licenses/>.
23 ;; Puppet show simulator.
25 (use-modules (8sync agenda)
31 (set! *random-state* (random-state-from-platform))
32 (define (random-choice lst)
33 (list-ref lst (random (length lst))))
37 '("Henry" "Harmony" "Rolf"))
39 (define (student-name-generator)
40 ;; a hashmap of student names with their current count
41 (define student-count (make-hash-table))
43 (let* ((student (random-choice student-names))
44 (current-number (hash-ref student-count student 1)))
45 (hash-set! student-count student (1+ current-number))
46 (format #f "~a-~a" student current-number))))
49 (define-actor <student> (<actor>)
51 (lambda* (actor message #:key target)
52 "Go bother a professor"
53 (while (not (student-dead actor))
54 (format #t "~a: Bother bother bother!\n"
55 (actor-id-actor actor))
56 (<- target 'be-bothered
57 #:noise "Bother bother bother!\n"))))
59 (be-lambda-consvardraed
60 (lambda (actor message)
61 "This kills the student."
62 (format #t "~a says: AAAAAAAHHHH!!! I'm dead!\n"
63 (actor-id-actor actor))
64 (set! (student-dead actor) #t))))
65 (name #:init-keyword #:name)
67 #:accessor student-dead))
70 '("Hey!" "Stop that!" "Oof!"))
72 (define (professor-be-bothered actor message . rest)
73 (define whos-bothering (professor-bothered-by actor))
74 (hash-set! whos-bothering (message-from message) #t)
77 (display (string-append (random-choice complaints)))
80 ;; More than one student is bothering us, lose our temper
81 (if (> (hash-count (const #t) whos-bothering)
84 (format #t "~s: LAMBDA CONSVARDRA!\n"
88 (<- student 'be-lambda-consvardraed)
89 ;; Remove student from bothering list
90 (hash-remove! whos-bothering student))
92 ;; Otherwise, remove them from the list and carry on
93 (hash-remove! whos-bothering (message-from message))))
95 (define-actor <professor> (<actor>)
96 ((be-bothered professor-be-bothered))
97 ;; This value checks whether any other actor is currently
98 ;; bothering this same character.
99 ;; We'll use a hash table as a fake set.
100 (bothered-by #:init-thunk make-hash-table
101 #:getter professor-bothered-by))
103 (define num-students 10)
105 (define (main . args)
106 (define agenda (make-agenda))
107 (define hive (make-hive))
108 (define professor (bootstrap-actor* hive <professor> "prof"))
109 (define namegen (student-name-generator))
113 (let ((name (namegen)))
114 (bootstrap-actor* hive <student> name
116 (iota num-students)))
118 ;; Bootstrap each student into bothering-professor mode.
119 (define start-bothering-tasks
122 (bootstrap-message hive student 'bother-professor
126 (run-hive hive start-bothering-tasks))