demos/actors/botherbotherbother.scm

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