Skip to content

Instantly share code, notes, and snippets.

@PuercoPop
Last active January 3, 2016 23:49
Show Gist options
  • Save PuercoPop/8537303 to your computer and use it in GitHub Desktop.
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)
(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))
(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
(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)))))
;; (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