demos/actors/botherbotherbother.scm

   1 #!/usr/bin/guile \
   2 -e main -s
   3 !#
   4
   5 ;;; 8sync --- Asynchronous programming for Guile
   6 ;;; Copyright © 2016, 2017 Christopher Allan Webber <cwebber@dustycloud.org>
   7 ;;;
   8 ;;; This file is part of 8sync.
   9 ;;;
  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.
  14 ;;;
  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.
  19 ;;;
  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/>.
  22
  23 ;; Puppet show simulator.
  24
  25 (use-modules (8sync actors)
  26              (oop goops)
  27              (ice-9 hash-table)
  28              (ice-9 format))
  29
  30 (set! *random-state* (random-state-from-platform))
  31 (define (random-choice lst)
  32   (list-ref lst (random (length lst))))
  33
  34
  35 (define student-names
  36   '("Henry" "Harmony" "Rolf"))
  37
  38 (define (student-name-generator)
  39   ;; a hashmap of student names with their current count
  40   (define student-count (make-hash-table))
  41   (lambda ()
  42     (let* ((student (random-choice student-names))
  43            (current-number (hash-ref student-count student 1)))
  44       (hash-set! student-count student (1+ current-number))
  45       (format #f "~a-~a" student current-number))))
  46
  47
  48 (define-actor <student> (<actor>)
  49   ((bother-professor
  50     (lambda* (actor message #:key target)
  51       "Go bother a professor"
  52       (while (not (student-dead actor))
  53         (format #t "~a: Bother bother bother!\n"
  54                 (actor-id-actor actor))
  55         (<- target 'be-bothered
  56             #:noise "Bother bother bother!\n"))))
  57
  58    (be-lambda-consvardraed
  59     (lambda (actor message)
  60       "This kills the student."
  61       (format #t "~a says: AAAAAAAHHHH!!! I'm dead!\n"
  62               (actor-id-actor actor))
  63       (set! (student-dead actor) #t))))
  64   (name #:init-keyword #:name)
  65   (dead #:init-value #f
  66         #:accessor student-dead))
  67
  68 (define complaints
  69   '("Hey!" "Stop that!" "Oof!"))
  70
  71 (define (professor-be-bothered actor message . rest)
  72   (define whos-bothering (professor-bothered-by actor))
  73   (hash-set! whos-bothering (message-from message) #t)
  74
  75   ;; Oof!  Those kids!
  76   (display (string-append (random-choice complaints)))
  77   (newline)
  78
  79   ;; More than one student is bothering us, lose our temper
  80   (if (> (hash-count (const #t) whos-bothering)
  81          1)
  82       (begin
  83         (format #t "~s: LAMBDA CONSVARDRA!\n"
  84                 (actor-id actor))
  85         (hash-for-each
  86          (lambda (student _)
  87            (<- student 'be-lambda-consvardraed)
  88            ;; Remove student from bothering list
  89            (hash-remove! whos-bothering student))
  90          whos-bothering))
  91       ;; Otherwise, remove them from the list and carry on
  92       (hash-remove! whos-bothering (message-from message))))
  93
  94 (define-actor <professor> (<actor>)
  95   ((be-bothered professor-be-bothered))
  96   ;; This value checks whether any other actor is currently
  97   ;; bothering this same character.
  98   ;; We'll use a hash table as a fake set.
  99   (bothered-by #:init-thunk make-hash-table
 100                #:getter professor-bothered-by))
 101
 102 (define num-students 10)
 103
 104 (define (main . args)
 105   (run-hive
 106    (lambda (hive)
 107      (define professor (bootstrap-actor* hive <professor> "prof"))
 108      (define namegen (student-name-generator))
 109      (define students
 110        (map
 111         (lambda _
 112           (let ((name (namegen)))
 113             (bootstrap-actor* hive <student> name
 114                               #:name name)))
 115         (iota num-students)))
 116
 117      ;; Bootstrap each student into bothering-professor mode.
 118      (define start-bothering-tasks
 119        (map
 120         (lambda (student)
 121           (<- student 'bother-professor
 122               #:target professor))
 123         students))
 124
 125      (run-hive hive start-bothering-tasks)
 126      ;; in other words, this program doesn't really halt
 127      (wait (make-condition)))))