From 3c40164d37f2a11e9439261625c9dd4385a27350 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 21 Apr 2016 22:44:47 -0500 Subject: demos: actors: A couple of simple actor model demos. * demos/actors/simplest-possible.scm: New file. Simplest possible demo: Two actors say hello to each other. * demos/actors/botherbotherbother.scm: New file. A little bit more complex; multiple actors interact with each other. Ensures that actors don't clobber each other unexpectedly. --- demos/actors/botherbotherbother.scm | 131 ++++++++++++++++++++++++++++++++++++ demos/actors/simplest-possible.scm | 41 +++++++++++ 2 files changed, 172 insertions(+) create mode 100644 demos/actors/botherbotherbother.scm create mode 100644 demos/actors/simplest-possible.scm diff --git a/demos/actors/botherbotherbother.scm b/demos/actors/botherbotherbother.scm new file mode 100644 index 0000000..3a2747a --- /dev/null +++ b/demos/actors/botherbotherbother.scm @@ -0,0 +1,131 @@ +;;; 8sync --- Asynchronous programming for Guile +;;; Copyright (C) 2016 Christopher Allan Webber +;;; +;;; This file is part of 8sync. +;;; +;;; 8sync is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; 8sync is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with 8sync. If not, see . + +;; Puppet show simulator. + +(use-modules (8sync agenda) + (8sync systems actors) + (oop goops) + (ice-9 hash-table) + (ice-9 format)) + +(set! *random-state* (random-state-from-platform)) +(define (random-choice lst) + (list-ref lst (random (length lst)))) + + +(define student-names + '("Henry" "Harmony" "Rolf")) + +(define (student-name-generator) + ;; a hashmap of student names with their current count + (define student-count (make-hash-table)) + (lambda () + (let* ((student (random-choice student-names)) + (current-number (hash-ref student-count student 1))) + (hash-set! student-count student (1+ current-number)) + (format #f "~a-~a" student current-number)))) + + +(define-class () + (name #:init-keyword #:name) + (dead #:init-value #f + #:accessor student-dead) + (message-handler + #:init-value + (make-action-dispatch + (bother-professor + (lambda (actor message) + "Go bother a professor" + (while (not (student-dead actor)) + (format #t "~a: Bother bother bother!\n" + (actor-id-actor actor)) + (send-message + actor (message-ref message 'target) + 'be-bothered + #:noise "Bother bother bother!\n")))) + + (be-lambda-consvardraed + (lambda (actor message) + "This kills the student." + (format #t "~a says: AAAAAAAHHHH!!! I'm dead!\n" + (actor-id-actor actor)) + (set! (student-dead actor) #t)))))) + +(define complaints + '("Hey!" "Stop that!" "Oof!")) + +(define (professor-be-bothered actor message) + (define whos-bothering (professor-bothered-by actor)) + + (hash-set! whos-bothering (message-from message) #t) + + ;; Oof! Those kids! + (display (string-append (random-choice complaints))) + + ;; More than one student is bothering us, lose our temper + (if (> (hash-count (const #t) whos-bothering) + 1) + (begin + (format #t "~s: LAMBDA CONSVARDRA!\n" + (actor-id actor)) + (hash-for-each + (lambda (student _) + (send-message + actor student + 'be-lambda-consvardraed) + ;; Remove student from bothering list + (hash-remove! whos-bothering student)) + whos-bothering)) + ;; Otherwise, remove them from the list and carry on + (hash-remove! whos-bothering (message-from message)))) + +(define-class () + ;; This value checks whether any other actor is currently + ;; bothering this same character. + ;; We'll use a hash table as a fake set. + (bothered-by #:init-thunk make-hash-table + #:getter professor-bothered-by) + (message-handler + #:init-value + (make-action-dispatch + (be-bothered professor-be-bothered)))) + +(define num-students 10) + +(define (main) + (define agenda (make-agenda)) + (define hive (make-hive)) + (define professor (hive-create-actor hive )) + (define namegen (student-name-generator)) + (define students + (map + (lambda _ + (hive-create-actor* hive + (#:name (namegen)))) + (iota num-students))) + + ;; Bootstrap each student into bothering-professor mode. + (define start-bothering-tasks + (map + (lambda (student) + (hive-bootstrap-message hive student 'bother-professor + #:target professor)) + students)) + + (ez-run-hive hive start-bothering-tasks)) diff --git a/demos/actors/simplest-possible.scm b/demos/actors/simplest-possible.scm new file mode 100644 index 0000000..1cd00ea --- /dev/null +++ b/demos/actors/simplest-possible.scm @@ -0,0 +1,41 @@ +;;; 8sync --- Asynchronous programming for Guile +;;; Copyright (C) 2016 Christopher Allan Webber +;;; +;;; This file is part of 8sync. +;;; +;;; 8sync is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; 8sync is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with 8sync. If not, see . + +(use-modules (8sync systems actors) + (ice-9 match) + (oop goops)) + +(define-simple-actor + ((greet-proog + (lambda (actor message) + (display "Heya Proog!\n") + (send-message + actor (message-ref message 'target) + 'greet-emo))))) + +(define-simple-actor + ((greet-emo + (lambda (actor message) + (display "Hi, Emo!\n"))))) + +(define hive (make-hive)) +(define our-emo (hive-create-actor hive )) +(define our-proog (hive-create-actor hive )) +(ez-run-hive hive + (list (hive-bootstrap-message hive our-emo 'greet-proog + #:target our-proog))) -- cgit v1.2.3-70-g09d2