Last active
January 3, 2016 23:49
-
-
Save PuercoPop/8537303 to your computer and use it in GitHub Desktop.
Use the fsm from hinge, used to parse http, and parse a torrent.file (starting with bstrings)
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(deffsm bdecode-int () | |
()) | |
(defstate bdecode-int :initial (fsm c) | |
(if (char= c #\i) | |
:read-number | |
:error)) | |
(defstate bdecode-int :read-number (fsm c) | |
(if (char= c #\e) | |
:initial | |
(prog1 :read-number | |
(princ c t)))) | |
(let ((fsm (make-instance 'bdecode-int)) | |
(input "i54e")) | |
(map 'list (lambda (c) (funcall fsm c)) input)) |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(in-package :cl-user) | |
(defpackage :fsm-demo | |
(:use :cl :fsm)) | |
(in-package :fsm-demo) | |
(fsm:deffsm bdecode-fsm () | |
(buffer :initarg :buffer :initform (list) :accessor buffer) | |
((content :initarg content :initform (list) :accessor content) | |
(counter :initarg counter :initform 0 :accessor counter))) | |
(defun is-digit? (c) | |
(member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0))) | |
(defstate bdecode-fsm :initial (fsm c) | |
(cond ((is-digit? c) | |
(progn (setf (counter fsm) (+ (* 10 (counter fsm)) (digit-char-p c))) | |
:initial)) | |
((char= #\: c) :read-string) | |
(t | |
:error))) | |
(defstate bdecode-fsm :read-string (fsm c) | |
;; Decrement counter and store the character. When the counter is | |
;; 0, print buffer and go to initial. | |
(setf (buffer fsm) (cons c (buffer fsm))) | |
(decf (counter fsm)) | |
(if (eq 0 (counter fsm)) | |
(prog1 :initial | |
(princ (reverse (buffer fsm)) t) | |
(setf (buffer fsm) nil)) | |
:read-string)) | |
(let ((fsm (make-instance 'bdecode-fsm)) | |
(input "10:hellohello")) | |
(map 'list | |
(lambda (c) | |
(if (eql :error (fsm:state fsm)) | |
(format t "Skipping: ~S~%" c) | |
(funcall fsm c))) | |
input) | |
(fsm:state fsm)) | |
;; (h e l l o h e l l o) | |
;; :INITIAL |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(in-package :cl-user) | |
(defpackage :fsm-demo | |
(:use :cl :fsm)) | |
(in-package :fsm-demo) | |
(fsm:deffsm bdecode-fsm () | |
((counter :initform 0 :accessor counter) | |
(stack :initform nil :accessor stack) | |
(output :initarg :output :reader output :documentation "Output stream to write to."))) | |
(defun is-digit? (c) | |
(member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0))) | |
(defstate bdecode-fsm :waiting (fsm c) | |
(cond | |
((char= #\i c) :read-number) | |
((char= #\l c) (prog1 :waiting | |
(format (output fsm) "[") | |
(setf (stack fsm) (cons 'list (stack fsm))))) | |
((char= #\d c) (prog1 :waiting | |
(format (output fsm) "{") | |
(setf (stack fsm) (cons 'dictionary (stack fsm)))) ) | |
((char= #\e c) | |
(cond | |
((eq 'list (car (stack fsm))) | |
(prog1 :waiting | |
(format (output fsm) "]~%") | |
(setf (stack fsm) (cdr (stack fsm))))) | |
((eq 'dictionary (car (stack fsm))) | |
(prog1 :waiting | |
(format (output fsm) "}~%") | |
(setf (stack fsm) (cdr (stack fsm))))) | |
(t :error))) | |
((is-digit? c) | |
(progn (setf (counter fsm) (+ (* 10 (counter fsm)) (digit-char-p c))) | |
:accum-counter)) | |
(t | |
:error))) | |
(defstate bdecode-fsm :accum-counter (fsm c) | |
(cond | |
((is-digit? c) | |
(progn (setf (counter fsm) (+ (* 10 (counter fsm)) (digit-char-p c))) | |
:accum-counter)) | |
((char= #\: c) :read-string) | |
(t :error))) | |
(defstate bdecode-fsm :read-number (fsm c) | |
(if (char= c #\e) | |
(prog1 :waiting | |
(format (output fsm) "~%")) | |
(prog1 :read-number | |
(format (output fsm) "~A" c)))) | |
(defstate bdecode-fsm :read-string (fsm c) | |
(decf (counter fsm)) | |
(if (eq 0 (counter fsm)) | |
(prog1 :waiting | |
(format (output fsm) "~A~%" c)) | |
(prog1 :read-string | |
(format (output fsm) "~A" c)))) | |
(with-open-file (input #P"~/archlinux.torrent" :direction :input) | |
(with-open-file (output #P"~/archlinux.output" :direction :output | |
:if-exists :supersede) | |
(let ((fsm (make-instance 'bdecode-fsm :state :waiting :output output))) | |
(do ((char (read-char input nil 'eof) | |
(read-char input nil 'eof))) | |
((eq char 'eof)) | |
(format t "Reading char: ~A~%Machine in state: ~A~%====~%" char(state fsm)) | |
(funcall fsm char))))) |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; (ql:quickload :closer-mop) | |
(defpackage :fsm | |
(:use :cl) | |
(:export :standard-state-machine | |
:standard-state-machine-event | |
:last-event | |
:state | |
:defstate | |
:deffsm)) | |
(in-package :fsm) | |
;; Basic copy-pasta protection | |
;; Get :closer-mop installed before running this code! | |
(unless (find-package :c2mop) | |
(error "Package :closer-mop is required for this system to load!")) | |
(defclass standard-state-machine (c2mop:funcallable-standard-object) | |
((state :initform :initial :initarg :state | |
:accessor state | |
:documentation "The current state of the state-machine.") | |
(last-event :initform (get-internal-real-time) | |
:accessor last-event | |
:documentation "The timestamp of the last event.")) | |
(:metaclass c2mop:funcallable-standard-class) | |
(:documentation "(funcall this-instance event-from-bus) | |
Every iteration of the event machine the `last-event' slot is updated with `get-internal-real-time' before | |
the funcallable instance application. | |
SUBCLASS NOTE: Make sure to include ```(:metaclass c2mop:funcallable-standard-class)``` in your | |
subclass definition, or else the funcallable instance will not function correctly.")) | |
(defgeneric standard-state-machine-event (machine state event) | |
(:documentation "Method specialized by `defstate' to handle the actual driving of | |
the state machine with events.")) | |
(defmethod initialize-instance :before ((machine standard-state-machine) &key) | |
"Bind a (funcallable machine event) driver to the event machine instance. | |
See `defstate' for the reasoning and function. This method is closure plumbing." | |
(c2mop:set-funcallable-instance-function | |
machine | |
#'(lambda (event) | |
(multiple-value-bind (next-state recur-p) | |
(standard-state-machine-event machine (state machine) event) | |
(setf (last-event machine) (get-internal-real-time) | |
(state machine) (or next-state (state machine))) | |
(if recur-p | |
(funcall machine event) | |
(values machine (state machine))))))) | |
(defmethod initialize-instance :after ((machine standard-state-machine) &key)) | |
(defmacro deffsm (name parents slots &rest options) | |
"Define an fsm `name' as in (defclass name parents slots options) | |
This macro takes care of the inheritance chain of `standard-state-machine' | |
and the funcallable metaclass" | |
`(defclass ,name ,(append (list 'standard-state-machine) parents) | |
,slots | |
(:metaclass c2mop:funcallable-standard-class) | |
,@options)) | |
(defmacro defstate (machine-type state-name (machine-sym event-sym) &body body) | |
"Helper macro to define states for the machine of type `machine-type'. | |
The generated state methods will be specialized on `machine-type' and | |
`state-name', and subclasses of `standard-state-machine' should use | |
this property to extend the state machine. | |
`state-name' is the identifier for this state, and names it. Event | |
invocations will use this name to determine which state the machine is | |
in, and error out if one cannot be found. The event will be bound to | |
the symbol named `event-sym' declared as in a two-argument lambda | |
list. Each invocation of this state with the even bound to | |
`event-sym' will evaluate `body' forms as in a method invocation and | |
the resulting value of the evaluation should return the next state for | |
the machine as a `:keyword', or `nil' to indicate the machine should | |
remain in its current state. The symbol named by `machine-sym' will | |
be bound to the currently executing state machine. The current state | |
is available in `state', though should be accessed as \"(state | |
machine-sym)\" | |
If the state produces two-value return, it is interpreted as (values | |
next-state recur-event) and if recur-event is non-nil the same event | |
is sent into the machine again after performing the transition into | |
next-state. This is useful if simply performing a state transition | |
would result in event starvation." | |
`(defmethod standard-state-machine-event | |
((,machine-sym ,machine-type) (state (eql ,state-name)) ,event-sym) | |
,@body)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment