demos/actors/botherbotherbother.scm

   1 ;;; 8sync --- Asynchronous programming for Guile
   2 ;;; Copyright (C) 2016 Christopher Allan Webber <cwebber@dustycloud.org>
   3 ;;;
   4 ;;; This file is part of 8sync.
   5 ;;;
   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.
  10 ;;;
  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.
  15 ;;;
  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/>.
  18
  19 ;; Puppet show simulator.
  20
  21 (use-modules (8sync agenda)
  22              (8sync systems actors)
  23              (oop goops)
  24              (ice-9 hash-table)
  25              (ice-9 format))
  26
  27 (set! *random-state* (random-state-from-platform))
  28 (define (random-choice lst)
  29   (list-ref lst (random (length lst))))
  30
  31
  32 (define student-names
  33   '("Henry" "Harmony" "Rolf"))
  34
  35 (define (student-name-generator)
  36   ;; a hashmap of student names with their current count
  37   (define student-count (make-hash-table))
  38   (lambda ()
  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))))
  43
  44
  45 (define-class <student> (<actor>)
  46   (name #:init-keyword #:name)
  47   (dead #:init-value #f
  48         #:accessor student-dead)
  49   (message-handler
  50    #:init-value
  51    (make-action-dispatch
  52     (bother-professor
  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))
  58          (send-message
  59           actor (message-ref message 'target)
  60           'be-bothered
  61           #:noise "Bother bother bother!\n"))))
  62
  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))))))
  69
  70 (define complaints
  71   '("Hey!" "Stop that!" "Oof!"))
  72
  73 (define (professor-be-bothered actor message)
  74   (define whos-bothering (professor-bothered-by actor))
  75
  76   (hash-set! whos-bothering (message-from message) #t)
  77
  78   ;; Oof!  Those kids!
  79   (display (string-append (random-choice complaints)))
  80
  81   ;; More than one student is bothering us, lose our temper
  82   (if (> (hash-count (const #t) whos-bothering)
  83          1)
  84       (begin
  85         (format #t "~s: LAMBDA CONSVARDRA!\n"
  86                 (actor-id actor))
  87         (hash-for-each
  88          (lambda (student _)
  89            (send-message
  90             actor student
  91             'be-lambda-consvardraed)
  92            ;; Remove student from bothering list
  93            (hash-remove! whos-bothering student))
  94          whos-bothering))
  95       ;; Otherwise, remove them from the list and carry on
  96       (hash-remove! whos-bothering (message-from message))))
  97
  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)
 104   (message-handler
 105    #:init-value
 106    (make-action-dispatch
 107     (be-bothered professor-be-bothered))))
 108
 109 (define num-students 10)
 110
 111 (define (main)
 112   (define agenda (make-agenda))
 113   (define hive (make-hive))
 114   (define professor (hive-create-actor hive <professor>))
 115   (define namegen (student-name-generator))
 116   (define students
 117     (map
 118      (lambda _
 119        (hive-create-actor* hive <student>
 120                            (#:name (namegen))))
 121      (iota num-students)))
 122
 123   ;; Bootstrap each student into bothering-professor mode.
 124   (define start-bothering-tasks
 125     (map
 126      (lambda (student)
 127        (hive-bootstrap-message hive student 'bother-professor
 128                                #:target professor))
 129      students))
 130
 131   (ez-run-hive hive start-bothering-tasks))