--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.ffignore Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,1 @@
+docs/build
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,4 @@
+syntax: glob
+
+docs/build
+scratch.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,23 @@
+.PHONY: pubdocs
+
+sourcefiles = $(shell ffind --full-path --dir src --literal .lisp)
+docfiles = $(shell ls docs/*.markdown)
+apidoc = docs/03-reference.markdown
+
+# src/utils.lisp: src/make-utilities.lisp
+# cd src && sbcl --noinform --load make-utilities.lisp --eval '(quit)'
+
+$(apidoc): $(sourcefiles) docs/api.lisp
+ sbcl --noinform --load docs/api.lisp --eval '(quit)'
+
+docs: docs/build/index.html
+
+docs/build/index.html: $(docfiles) docs/title
+ cd docs && ~/.virtualenvs/d/bin/d
+
+pubdocs: docs
+ hg -R ~/src/sjl.bitbucket.org pull -u
+ rsync --delete -a ./docs/build/ ~/src/sjl.bitbucket.org/cl-ggp
+ hg -R ~/src/sjl.bitbucket.org commit -Am 'cl-ggp: Update site.'
+ hg -R ~/src/sjl.bitbucket.org push
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,15 @@
+The GGP Protocol looks approximately like this:
+
+ (START <MATCH ID> <ROLE> <GAME DESCRIPTION> <STARTCLOCK> <PLAYCLOCK>)
+ READY
+
+ (PLAY <MATCH ID> <PRIOR MOVES>)
+ MOVE (explanation “...”) (taunt “...”)
+
+ (STOP <MATCH ID> <PRIOR MOVES>)
+ DONE
+
+Undocumented, because lol:
+
+ (INFO)
+ ((NAME MYNAME) (STATUS ???) (SPECIES LOL))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cl-ggp.asd Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,21 @@
+(asdf:defsystem #:cl-ggp
+ :name "ggp"
+ :description "A framework for writing General Game Playing clients."
+
+ :author "Steve Losh <steve@stevelosh.com>"
+ :maintainer "Steve Losh <steve@stevelosh.com>"
+
+ :license "MIT/X11"
+ :version "0.0.1"
+
+ :depends-on (#:clack
+ #:flexi-streams
+ #:optima
+ #:fare-quasiquote-optima
+ #:fare-quasiquote-readtable)
+
+ :serial t
+ :components ((:file "package")
+ (:module "src"
+ :components ((:file "ggp")))))
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/01-installation.markdown Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,2 @@
+Installation
+============
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/02-overview.markdown Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,83 @@
+Overview
+========
+
+`cl-ggp` handles the GGP protocol for you. Players are implemented as CLOS
+objects.
+
+[TOC]
+
+Basics
+------
+
+You can create your own player by extending the `ggp-player` class, creating an
+object, and calling `start-player` on it to fire it up:
+
+ (defclass simple-player (ggp:ggp-player)
+ ())
+
+ (defvar *player* (make-instance 'simple-player
+ :name "SimplePlayer"
+ :port 4000))
+
+ (ggp:start-player *player*)
+
+`ggp-player` takes `:name` and `:port` initargs. It has a few other internal
+slots you shouldn't mess with.
+
+You can kill a player with `kill-player`.
+
+Functionality
+-------------
+
+`cl-ggp` defines four generic methods that are called on players at various
+points in each game. You can provide method definitions for some or all of
+these to let your player do whatever it needs to do.
+
+At a minimum you **must** implement `player-select-move`. The others are
+optional and will default to doing nothing.
+
+### player-start-game
+
+ (defmethod player-start-game ((player YOUR-PLAYER) rules role start-clock play-clock)
+ ...)
+
+This is called when a new game starts.
+
+`rules` is the GDL rules of the game, parsed into Lisp lists/symbols. You'll
+probably want to feed this into a logic library.
+
+`role` is a symbol representing which role you've been assigned.
+
+`start-clock` is
+
+`play-clock` is
+
+### player-update-game
+
+ (defmethod player-update-game ((player YOUR-PLAYER) moves)
+ ...)
+
+This is called once per turn, to update the game state with the moves each
+player selected.
+
+`moves` is a list of the moves made by all players.
+
+### player-select-move
+
+ (defmethod player-select-move ((player YOUR-PLAYER))
+ ...)
+
+This is called once per turn. It should return the move your player wants to
+do. All players **must** implement this function.
+
+### player-stop-game
+
+ (defmethod player-stop-game ((player YOUR-PLAYER))
+ ...)
+
+This is called when the game is stopped. You can use it for things like tearing
+down any extra data structures you've made, suggesting a GC to your Lisp, etc.
+
+Example Player
+--------------
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/03-reference.markdown Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,14 @@
+# API Reference
+
+The following is a list of all user-facing parts of `cl-ggp`.
+
+If there are backwards-incompatible changes to anything listed here, they will
+be noted in the changelog and the author will feel bad.
+
+Anything not listed here is subject to change at any time with no warning, so
+don't touch it.
+
+[TOC]
+
+## Package GGP
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/04-changelog.markdown Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,2 @@
+Changelog
+=========
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/api.lisp Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,130 @@
+(let ((*standard-output* (make-broadcast-stream)))
+ (ql:quickload "docparser"))
+
+(defparameter *index*
+ (docparser:parse :cl-ggp))
+
+(defparameter *document-packages*
+ (list "GGP"))
+
+(defparameter *header*
+ "The following is a list of all user-facing parts of `cl-ggp`.
+
+If there are backwards-incompatible changes to anything listed here, they will
+be noted in the changelog and the author will feel bad.
+
+Anything not listed here is subject to change at any time with no warning, so
+don't touch it.
+
+")
+
+
+;;;; From the CL Cookbook
+(defun replace-all (string part replacement &key (test #'char=))
+ "Returns a new string in which all the occurences of the part
+is replaced with replacement."
+ (with-output-to-string (out)
+ (loop with part-length = (length part)
+ for old-pos = 0 then (+ pos part-length)
+ for pos = (search part string
+ :start2 old-pos
+ :test test)
+ do (write-string string out
+ :start old-pos
+ :end (or pos (length string)))
+ when pos do (write-string replacement out)
+ while pos)))
+
+
+;;;; Documentation Utils
+(defun get-doc (package-name symbol-name)
+ (elt (docparser:query *index*
+ :package-name package-name
+ :symbol-name symbol-name)
+ 0))
+(defun get-package-doc (package-name)
+ ;; good god, lemon
+ (docparser::find-package-index *index* package-name))
+
+
+;;;; Markdown Rendering
+(defun render-package-header (package-name)
+ (format t "## Package ~A~%~%"
+ (replace-all package-name "*" "\\*")))
+
+(defun render-package-docstring (package-name)
+ (let ((package-docstring
+ (docparser::package-index-docstring (get-package-doc package-name))))
+ (when package-docstring
+ (format t "~A~%~%" package-docstring))))
+
+(defun render-symbol-header (symbol-name extra)
+ (format t "### ~A~A~%~%"
+ (replace-all symbol-name "*" "\\*")
+ extra))
+
+(defun render-docstring (node)
+ (let ((documentation (docparser:node-docstring node)))
+ (when documentation
+ (format t "~A~%~%" documentation))))
+
+(defun render-lambda-list (node)
+ (format t " ~A~%~%"
+ (cons (docparser:node-name node)
+ (docparser:operator-lambda-list node))))
+
+(defgeneric render-documentation (node symbol-name))
+
+
+(defmethod render-documentation ((node docparser:documentation-node) symbol-name)
+ (render-symbol-header symbol-name "")
+ (format t "`~A`~%~%" (class-of node))
+ (render-docstring node))
+
+(defmethod render-documentation ((node docparser:variable-node) symbol-name)
+ (render-symbol-header symbol-name " (variable)")
+ (render-docstring node))
+
+(defmethod render-documentation ((node docparser:function-node) symbol-name)
+ (render-symbol-header symbol-name " (function)")
+ (render-lambda-list node)
+ (render-docstring node))
+
+(defmethod render-documentation ((node docparser:macro-node) symbol-name)
+ (render-symbol-header symbol-name " (macro)")
+ (render-lambda-list node)
+ (render-docstring node))
+
+
+;;;; Documentation Sections
+(defun document-symbol (package-name symbol)
+ (let* ((symbol-name (symbol-name symbol))
+ (doc-node (get-doc package-name symbol-name)))
+ (render-documentation doc-node symbol-name)))
+
+(defun document-package (package-name)
+ (render-package-header package-name)
+ (render-package-docstring package-name)
+ (let ((symbols (loop :for s :being :the external-symbol :of package-name
+ :collect s)))
+ (mapc #'(lambda (symbol)
+ (document-symbol package-name symbol))
+ (sort symbols #'string-lessp :key #'symbol-name))))
+
+(defun document-header ()
+ (format t "# API Reference~%~%")
+ (format t *header*)
+ (format t "[TOC]~%~%"))
+
+
+;;;; Main
+(defun main ()
+ (with-open-file (*standard-output* #p"docs/03-reference.markdown"
+ :direction :output
+ :if-exists :supersede)
+ (document-header)
+ (mapc #'document-package *document-packages*)))
+
+
+(main)
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/footer.markdown Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,14 @@
+<i>Made with Lisp and love by [Steve Losh][] in Reykjavík, Iceland.</i>
+
+[Steve Losh]: http://stevelosh.com/
+
+<script>
+ (function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){
+ (i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement(o),
+ m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.insertBefore(a,m)
+ })(window,document,'script','//www.google-analytics.com/analytics.js','ga');
+
+ ga('create', 'UA-15328874-3', 'auto');
+ ga('send', 'pageview');
+
+</script>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/index.markdown Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,11 @@
+`cl-ggp` is a tiny framework for writing [GGP][] players in Common Lisp.
+
+It handles the GGP protocol for you but *nothing else*. In particular you'll
+need to bring your own logic system to parse the games.
+
+[GGP]: http://www.ggp.org/
+
+* **License:** MIT/X11
+* **Documentation:** <http://sjl.bitbucket.org/cl-ggp/>
+* **Code:** <http://bitbucket.org/sjl/cl-ggp/>
+* **Issues:** <http://bitbucket.org/sjl/cl-ggp/issues/>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/docs/title Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,1 @@
+cl-ggp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/package.lisp Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,18 @@
+(defpackage #:ggp
+ (:use #:cl #:optima)
+ (:import-from #:optima #:match)
+ (:export
+ :ggp-player
+
+ :player-start-game
+ :player-update-game
+ :player-select-move
+ :player-stop-game
+
+ :player-name
+ :player-port
+
+ :start-player
+ :kill-player
+ ))
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/example.lisp Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,19 @@
+(in-package #:cl-user)
+
+(defclass simple-player (ggp:ggp-player)
+ ())
+
+(defmethod ggp:player-select-move ((player simple-player))
+ 'wait)
+
+(defvar *player* nil)
+
+(setf *player* (make-instance 'simple-player
+ :name "SimplePlayer"
+ :port 5000))
+
+
+(ggp:start-player *player*)
+(ggp:kill-player *player*)
+
+(setf (slot-value *player* 'ggp::current-match) nil)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/ggp.lisp Wed Mar 23 15:19:48 2016 +0000
@@ -0,0 +1,144 @@
+(in-package #:ggp)
+(named-readtables:in-readtable :fare-quasiquote)
+
+(defparameter *debug*
+ t)
+
+(defparameter *ggp-package*
+ (find-package :ggp))
+
+
+;;;; GGP Player
+(defclass ggp-player ()
+ ((name :initarg :name :initform "CL-GGP" :reader player-name)
+ (port :initarg :port :initform 9999 :reader player-port)
+ (current-match :initform nil)
+ (server)))
+
+(defgeneric player-start-game (player rules role start-clock play-clock))
+(defgeneric player-update-game (player moves))
+(defgeneric player-select-move (player))
+(defgeneric player-stop-game (player))
+
+
+(defmethod player-start-game ((player ggp-player) rules role start-clock play-clock)
+ nil)
+
+(defmethod player-update-game ((player ggp-player) moves)
+ nil)
+
+(defmethod player-select-move ((player ggp-player))
+ (error "Required method player-select-move is not implemented for ~A" player))
+
+(defmethod player-stop-game ((player ggp-player))
+ nil)
+
+
+;;;; Utils
+(defun safe-read-from-string (s)
+ ;; what could go wrong
+ (let ((*read-eval* nil)
+ (*package* *ggp-package*))
+ (read-from-string s)))
+
+(defun render-to-string (e)
+ (let ((*package* *ggp-package*))
+ (format nil "~A" e)))
+
+
+;;;; Clack Horseshit
+(defun l (&rest args)
+ (when *debug*
+ (apply #'format *debug-io* args)))
+
+(defun resp (body &key (code 200) (content-type "text/acl"))
+ (list code
+ (list :content-type content-type
+ :content-length (length body))
+ (list body)))
+
+(defun get-body (env)
+ ;; jesus christ clack why do i have to write this shit
+ (let ((body (make-array (getf env :content-length)
+ :element-type 'flex:octet)))
+ (read-sequence body (getf env :raw-body))
+ (flex:octets-to-string body)))
+
+
+;;;; GGP Protocol
+(defun handle-info (player)
+ `((name ,(slot-value player 'name))
+ (status ,(if (slot-value player 'current-match) 'busy 'available))
+ (species alien)))
+
+(defun handle-start (player match-id role rules start-clock play-clock)
+ (declare (ignore play-clock))
+ (setf (slot-value player 'current-match) match-id)
+ (l "Starting match ~S as ~S~%" match-id role)
+ (player-start-game player rules role start-clock play-clock)
+ 'ready)
+
+(defun handle-play (player match-id moves)
+ (l "Handling play request with moves ~S~%" moves)
+ (player-update-game player moves)
+ (player-select-move player))
+
+(defun handle-stop (player match-id moves)
+ (l "Handling stop request for ~S~%" match-id)
+ (player-stop-game player)
+ (setf (slot-value player 'current-match) nil)
+ 'done)
+
+
+(defun route (player request)
+ "Route the request to the appropriate player function."
+ (match request
+ (`(info)
+ (handle-info player))
+
+ (`(play ,match-id ,moves)
+ (handle-play player match-id moves))
+
+ (`(stop ,match-id ,moves)
+ (handle-stop player match-id moves))
+
+ (`(start ,match-id ,role ,rules ,start-clock ,play-clock)
+ (handle-start player match-id role rules start-clock play-clock))
+
+ (unknown-request
+ (l "UNKNOWN REQUEST: ~S~%~%" unknown-request)
+ 'what)))
+
+(defun should-log-p (request)
+ (match request
+ (`(info) nil)
+ (_ t)))
+
+;;;; Boilerplate
+(defun app (player env)
+ (let* ((body (get-body env))
+ (request (safe-read-from-string body))
+ (should-log (should-log-p request)))
+ (when should-log
+ (l "~%~%Got a request ====================================~%")
+ (l "~S~%" request)
+ (l "==================================================~%"))
+ (let* ((response (route player request))
+ (rendered-response (render-to-string response)))
+ (when should-log
+ (l "==================================================~%")
+ (l "Responding with:~%~A~%" rendered-response)
+ (l "==================================================~%"))
+ (resp rendered-response))))
+
+
+;;;; Spinup/spindown
+(defun start-player (player)
+ (let* ((player-handler #'(lambda (env) (app player env)))
+ (server (clack:clackup player-handler
+ :port (player-port player))))
+ (setf (slot-value player 'server) server)
+ player))
+
+(defun kill-player (player)
+ (clack.handler:stop (slot-value player 'server)))