Skip to content

Instantly share code, notes, and snippets.

@aragaer
Created February 17, 2019 01:13
Show Gist options
  • Save aragaer/c5ca41d97109dd7671a11de02b28fac8 to your computer and use it in GitHub Desktop.
Save aragaer/c5ca41d97109dd7671a11de02b28fac8 to your computer and use it in GitHub Desktop.
scheme coroutines
(define (msg-type msg)
(cdr (assoc 'type msg)))
(define (msg-class msg)
(cdr (assoc 'class msg)))
(define (msg-data msg)
(cdr (assoc 'data msg)))
(define (msg-cmd msg)
(cdr (assoc 'command msg)))
(define ((is-msg-class? class) msg)
(and (string=? (msg-type msg) "msg")
(string=? (msg-class msg) class)))
(define-syntax await
(er-macro-transformer
(lambda (exp rename compare)
(let ((func (cadr exp))
(result (rename 'result))
(new-yield-to (rename 'new-yield-to)))
`(let-values (((,result ,new-yield-to) (,func yield-to)))
(set! yield-to ,new-yield-to)
,result)))))
(define-syntax define-coro
(er-macro-transformer
(lambda (exp rename compare)
(let ((name (caadr exp))
(args (map (lambda (n) `(define ,n '())) (cdadr exp)))
(body (cddr exp)))
`(define (,name yield-to)
,@args
(values (begin ,@body) yield-to))))))
(define ((ask-for-data test extract) yield-to)
(call/cc (lambda (back-here)
(yield-to (list (make-request test extract back-here))))))
(define-coro (echo text)
(say "Enter text for echo")
(define text (await (ask-for-data (is-msg-class? "text") msg-data)))
(say text))
(define-coro ((unknown-command cmd))
(say (string-append "Unknown command: " cmd)))
(define-coro (addition x y)
(say "x?")
(define x (await (ask-for-data (is-msg-class? "number") (o string->number msg-data))))
(say "y?")
(define y (await (ask-for-data (is-msg-class? "number") (o string->number msg-data))))
(say (string-append "Result: " (number->string (+ x y)))))
(define-coro (yes-or-no)
(await (ask-for-data
(lambda (msg)
(and (is-msg-class? "text")
(let ((t (msg-data msg)))
(or (string-ci=? t "y")
(string-ci=? t "n")))))
(lambda (msg)
(string-ci=? (msg-data msg) "y")))))
(define-coro ((grow v) change)
(say (string-append "Current value is " (number->string v)))
(say "Change how much?")
(define change (await (ask-for-data (is-msg-class? "number") (o string->number msg-data))))
(if (and (> 0 change) (< v (- change)))
(begin
(say "It won't go negative! Are you sure?")
(when (await yes-or-no)
(set! v (+ v change))
(say (string-append "Ok, it's now " (number->string v) ". It's your fault!"))))
(set! v (+ v change)))
(when (< 0 v)
(say (string-append "Value is now " (number->string v)))
(say "Continue?")
(if (await yes-or-no)
(await (grow v))
(say "Ok, bye!"))))
(define queue (make-queue))
(define make-request list)
(define queue-item-test car)
(define queue-item-extract cadr)
(define queue-item-return caddr)
(define actions (make-queue))
(define (queue-action action)
(queue-add! actions action))
(define (say msg)
(queue-action (lambda ()
(print msg))))
(define (remove-one matches? list)
(cond ((null? list) (values 'no-match '()))
((matches? (car list)) (values (car list) (cdr list)))
(else (let-values (((matched filtered) (remove-one matches? (cdr list))))
(values matched (cons (car list) filtered))))))
(define ((yield ret) requests)
(for-each (lambda (request)
(queue-add! queue request))
requests)
(ret '()))
(define (handle-command msg)
(let ((command (msg-cmd msg)))
(let ((func (cond
((string=? "echo" command) echo)
((string=? "add" command) addition)
((string=? "grow" command) (grow 1))
(else (unknown-command command)))))
(call/cc (lambda (here)
(func (yield here)))))))
(define (handle-message-or-event msg)
(let-values (((matched filtered) (remove-one
(lambda (item)
((queue-item-test item) msg))
(queue->list queue))))
(set! queue (list->queue filtered))
(if (eq? matched 'no-match)
(say "dont-understand")
(call/cc (lambda (handler)
((queue-item-return matched)
((queue-item-extract matched) msg)
(yield handler)))))))
(define (main)
(let ((queued (queue->list actions)))
(set! actions (make-queue))
(for-each (lambda (a) (a)) queued))
(let ((msg (get-message)))
(if (string=? (msg-type msg) "command")
(handle-command msg)
(handle-message-or-event msg))))
(define (loop)
(main)
(loop))
(define get-message read)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment