(ql:quickload :bordeaux-threads)
(ql:quickload :alexandria)
(ql:quickload :iterate)
(ql:quickload :cl-syntax-annot)
(defpackage :thread-based-continuation
(:use :cl :bordeaux-threads :alexandria
:iterate
:cl-syntax))
(in-package :thread-based-continuation)
(use-syntax :annot)
(defun permutations (n)
(let (acc)
(map-permutations
(lambda (permutation)
(push permutation acc))
(iota n))
acc))
;; get all possible permutations, one by one
(permutations 5)
;; e.g.
;; ((2 1 4 3 0) (1 2 4 3 0) (4 2 1 3 0) (2 4 1 3 0) (1 4 2 3 0) (4 1 2 3 0)
;; (3 1 4 2 0) (1 3 4 2 0) (4 3 1 2 0) (3 4 1 2 0) (1 4 3 2 0) (4 1 3 2 0)
;; (3 2 4 1 0) (2 3 4 1 0) (4 3 2 1 0) (3 4 2 1 0) (2 4 3 1 0) (4 2 3 1 0)
;; (3 2 1 4 0) (2 3 1 4 0) (1 3 2 4 0) (3 1 2 4 0) (2 1 3 4 0) (1 2 3 4 0)
;; (3 2 0 4 1) (2 3 0 4 1) (0 3 2 4 1) (3 0 2 4 1) (2 0 3 4 1) (0 2 3 4 1)
;; (4 2 0 3 1) (2 4 0 3 1) (0 4 2 3 1) (4 0 2 3 1) (2 0 4 3 1) (0 2 4 3 1)
;; (4 3 0 2 1) (3 4 0 2 1) (0 4 3 2 1) (4 0 3 2 1) (3 0 4 2 1) (0 3 4 2 1)
;; (4 3 2 0 1) (3 4 2 0 1) (2 4 3 0 1) (4 2 3 0 1) (3 2 4 0 1) (2 3 4 0 1)
;; (4 3 1 0 2) (3 4 1 0 2) (1 4 3 0 2) (4 1 3 0 2) (3 1 4 0 2) (1 3 4 0 2)
;; (0 3 1 4 2) (3 0 1 4 2) (1 0 3 4 2) (0 1 3 4 2) (3 1 0 4 2) (1 3 0 4 2)
;; (0 4 1 3 2) (4 0 1 3 2) (1 0 4 3 2) (0 1 4 3 2) (4 1 0 3 2) (1 4 0 3 2)
;; (0 4 3 1 2) (4 0 3 1 2) (3 0 4 1 2) (0 3 4 1 2) (4 3 0 1 2) (3 4 0 1 2)
;; (0 4 2 1 3) (4 0 2 1 3) (2 0 4 1 3) (0 2 4 1 3) (4 2 0 1 3) (2 4 0 1 3)
;; (1 4 2 0 3) (4 1 2 0 3) (2 1 4 0 3) (1 2 4 0 3) (4 2 1 0 3) (2 4 1 0 3)
;; (1 0 2 4 3) (0 1 2 4 3) (2 1 0 4 3) (1 2 0 4 3) (0 2 1 4 3) (2 0 1 4 3)
;; (1 0 4 2 3) (0 1 4 2 3) (4 1 0 2 3) (1 4 0 2 3) (0 4 1 2 3) (4 0 1 2 3)
;; (1 0 3 2 4) (0 1 3 2 4) (3 1 0 2 4) (1 3 0 2 4) (0 3 1 2 4) (3 0 1 2 4)
;; (2 0 3 1 4) (0 2 3 1 4) (3 2 0 1 4) (2 3 0 1 4) (0 3 2 1 4) (3 0 2 1 4)
;; (2 1 3 0 4) (1 2 3 0 4) (3 2 1 0 4) (2 3 1 0 4) (1 3 2 0 4) (3 1 2 0 4)
;; (2 1 0 3 4) (1 2 0 3 4) (0 2 1 3 4) (2 0 1 3 4) (1 0 2 3 4) (0 1 2 3 4))
;; (permutations 10) ;; memory bloat !!!
;; countermeasure
@export
(defun force (thunk)
(if (functionp thunk)
(funcall thunk)
thunk))
@export
(defmacro forcef (place)
(multiple-value-bind (vars vals store-vars writer reader)
(get-setf-expansion place)
@ignorable reader
`(let* (,@(iter (for var in vars)
(for val in vals)
(collect `(,var ,val)))
(,(car store-vars) (force ,reader)))
,writer)))
@export
(defmacro lcons (a b)
"cons whose car and cdr is lazy"
`(cons (lambda () ,a)
(lambda () ,b)))
(defmacro define-forced (name accessor &rest args)
`(defun ,name ,args
(forcef (,accessor ,@args))))
(defmacro define-forced-many (&rest args-list)
`(progn
,@(iter (for args in args-list)
(for forced = (symbolicate 'f (car args)))
(collect `(progn (export ',forced)
(define-forced ,forced ,@args))))))
(define-forced-many
(cdr lcons)
(car lcons)
(cddr lcons)
(cdddr lcons)
(cddddr lcons)
(caar lcons)
(caaar lcons)
(caaaar lcons)
(cadr lcons)
(cdar lcons)
(first lcons)
(second lcons)
(third lcons)
(fourth lcons)
(fifth lcons))
@export
(defmacro fpop (place)
(multiple-value-bind (vars vals store-vars writer reader)
(get-setf-expansion place)
@ignorable reader writer
(with-gensyms (list-head car)
`(let* (,@(mapcar #'list vars vals)
(,list-head ,reader))
(when ,list-head
(let* ((,car (fcar ,list-head))
(,(car store-vars) (fcdr ,list-head))
,@(cdr store-vars))
,writer
,car))))))
;; lazy eval + thread-based async continuation
(defun permutations2 (n)
(let ((caller-cv (make-condition-variable :name "caller"))
(caller-lock (make-lock "caller"))
(callee-cv (make-condition-variable :name "callee"))
(callee-lock (make-lock "callee"))
(channel nil))
;; I guess this thread should be properly destroyed when GC runs,
;; with the aid of trivial-garbage or some kind.
;; Otherwise it will cause the memory leakage
;; (because there may be many waiting threads)
(make-thread
(lambda ()
(with-lock-held (caller-lock)
(map-permutations
(lambda (permutation)
(condition-wait caller-cv caller-lock)
(setf channel permutation)
(condition-notify callee-cv))
(iota n))))
:name "callee")
(labels ((rec ()
(lcons (with-lock-held (callee-lock)
(condition-notify caller-cv)
(condition-wait callee-cv callee-lock)
channel)
(rec))))
(rec))))
(permutations2 10)
;; (#<CLOSURE (LAMBDA # :IN PERMUTATIONS2) {1008B3A7FB}>
;; . #<CLOSURE (LAMBDA # :IN PERMUTATIONS2) {1008B3A82B}>)
(defvar lazy-list *)
;; THREAD-BASED-CONTINUATION> (fpop lazy-list)
;; (0 1 2 3 4 5 6 7 8 9)
;; THREAD-BASED-CONTINUATION> (fpop lazy-list)
;; (1 0 2 3 4 5 6 7 8 9)
;; THREAD-BASED-CONTINUATION> (fpop lazy-list)
;; (2 0 1 3 4 5 6 7 8 9)
;; THREAD-BASED-CONTINUATION> (fpop lazy-list)
;; (0 2 1 3 4 5 6 7 8 9)
;; THREAD-BASED-CONTINUATION> (fpop lazy-list)
;; (1 2 0 3 4 5 6 7 8 9)
;; THREAD-BASED-CONTINUATION> (fpop lazy-list)
;; (2 1 0 3 4 5 6 7 8 9)
;; THREAD-BASED-CONTINUATION> (fpop lazy-list)
;; (3 1 2 0 4 5 6 7 8 9)
おまけ
@export
(defmacro llist (a &rest args)
"list using lcons"
`(lcons ,a ,(when args `(llist ,@args))))
@export
(defmacro ltree (tree)
(if (consp tree)
`(llist ,@(mapcar (lambda (e) `(ltree ,e)) tree))
tree))