--- a/Makefile Tue Jan 17 11:08:42 2017 +0000
+++ b/Makefile Wed Jan 18 00:32:30 2017 +0000
@@ -15,11 +15,9 @@
update-deps:
hg -R /home/sjl/chancery -v pull -u
+ hg -R /home/sjl/cl-losh -v pull -u
-/opt/antipodes/antipodes: update-deps build/antipodes
- rm -f /opt/antipodes/antipodes
- cp build/antipodes /opt/antipodes/antipodes
-
-deploy: build/magitek
+deploy: build/magitek update-deps
rsync --exclude=build/magitek --exclude=.hg --exclude=database.sqlite --exclude=corpora -avz . silt:/home/sjl/magitek
+ ssh silt make -C /home/sjl/magitek update-deps
ssh silt make -C /home/sjl/magitek build/magitek
--- a/magitek.asd Tue Jan 17 11:08:42 2017 +0000
+++ b/magitek.asd Wed Jan 18 00:32:30 2017 +0000
@@ -37,5 +37,6 @@
(:file "markov")
(:module "robots"
:components ((:file "git-commands")
- (:file "hacker-booze")))
+ (:file "hacker-booze")
+ (:file "rpg-shopkeeper")))
(:file "main")))))
--- a/package.lisp Tue Jan 17 11:08:42 2017 +0000
+++ b/package.lisp Wed Jan 18 00:32:30 2017 +0000
@@ -46,6 +46,16 @@
:magitek.quickutils)
(:export :random-string))
+(defpackage :magitek.robots.rpg-shopkeeper
+ (:use
+ :cl
+ :iterate
+ :cl-arrows
+ :losh
+ :chancery
+ :magitek.quickutils)
+ (:export :random-string))
+
(defpackage :magitek.robots.hacker-booze
(:use
:cl
--- a/src/main.lisp Tue Jan 17 11:08:42 2017 +0000
+++ b/src/main.lisp Wed Jan 18 00:32:30 2017 +0000
@@ -28,4 +28,6 @@
(db-initialize)
(tt-load-credentials)
(run-bot :git-commands #'magitek.robots.git-commands:random-string
+ :hours 12)
+ (run-bot :rpg-shopkeeper #'magitek.robots.rpg-shopkeeper:random-string
:hours 12))
--- a/src/robots/hacker-booze.lisp Tue Jan 17 11:08:42 2017 +0000
+++ b/src/robots/hacker-booze.lisp Wed Jan 18 00:32:30 2017 +0000
@@ -17,8 +17,8 @@
;;;; Hacker News --------------------------------------------------------------
(defparameter *errors* 0)
-(defparameter *stories-per-corpus* 20)
-(defparameter *max-comments-per-story* 100)
+(defparameter *stories-per-corpus* 30)
+(defparameter *max-comments-per-story* 200)
(defparameter *hn-corpus-path* "corpora/hacker-news.txt")
(defun firebase-get (url)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/robots/rpg-shopkeeper.lisp Wed Jan 18 00:32:30 2017 +0000
@@ -0,0 +1,314 @@
+(in-package :magitek.robots.rpg-shopkeeper)
+(named-readtables:in-readtable :chancery)
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;;; please just end my life
+ (defmacro ea (&body body)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@body)))
+
+
+;;;; General ------------------------------------------------------------------
+(define-rule (bonus :distribution (:zipf :exponent 1.8))
+ 1 2 3 4 5)
+
+
+(ea (defun str (symbol)
+ (string-downcase (symbol-name symbol))))
+
+
+;;;; Materials ----------------------------------------------------------------
+(defclass* material ()
+ (name multiplier))
+
+(defun make-material (name multiplier)
+ (make-instance 'material :name name :multiplier multiplier))
+
+(defmethod print-object ((o material) s)
+ (print-unreadable-object (o s :type t)
+ (princ (material-name o) s)))
+
+(defmacro define-material (name multiplier)
+ `(defparameter ,(symb '* name '*)
+ (make-material ,(string-downcase (substitute #\space #\- (symbol-name name)))
+ ,multiplier)))
+
+
+(define-material iron 1.0)
+(define-material steel 1.5)
+(define-material silver 2.0)
+(define-material meteoric-iron 4.0)
+(define-material mithril 10.0)
+(define-material adamantine 11.0)
+
+
+(define-material cloth 1.0)
+(define-material leather 1.5)
+(define-material silk 2.0)
+(define-material spider-silk 6.0)
+
+
+(define-material pine 1.0) ; http://www.wood-database.com/wood-articles/bow-woods/
+(define-material poplar 1.2)
+(define-material walnut 1.3)
+(define-material maple 2.0)
+(define-material oak 3.0)
+(define-material yew 5.0)
+(define-material rosewood 10.0)
+
+
+(define-rule (metal :distribution :zipf)
+ *iron*
+ *steel*
+ *silver*
+ *meteoric-iron*
+ *mithril*
+ *adamantine*)
+
+(define-rule (textile :distribution :weighted)
+ (1.00 *cloth*)
+ (1.00 *leather*)
+ (0.80 *silk*)
+ (0.01 *spider-silk*))
+
+(define-rule (wood :distribution (:zipf :exponent 0.8))
+ *pine*
+ *poplar*
+ *walnut*
+ *maple*
+ *oak*
+ *yew*
+ *rosewood*)
+
+
+;;;; Monsters -----------------------------------------------------------------
+(defclass* monster ()
+ (singular multiplier plural adjective))
+
+(defun make-monster (singular multiplier plural adjective)
+ (make-instance 'monster
+ :singular singular
+ :multiplier multiplier
+ :plural plural
+ :adjective adjective))
+
+(defmethod print-object ((o monster) s)
+ (print-unreadable-object (o s :type t)
+ (princ (monster-singular o) s)))
+
+(defmacro define-monster (singular multiplier plural adjective)
+ `(defparameter ,(symb '* singular '*)
+ (make-monster
+ ,(str singular)
+ ,multiplier
+ ,(str plural)
+ ,(str adjective))))
+
+
+(define-monster goblin 1.00 goblins goblin)
+(define-monster kobold 1.00 kobolds kobold)
+(define-monster elf 1.00 elves elven)
+(define-monster dwarf 1.00 dwarves dwarven)
+(define-monster halfling 1.00 halflings halfling)
+(define-monster gnome 1.00 gnomes gnomish)
+(define-monster gnoll 1.10 gnolls gnollish)
+(define-monster ogre 1.20 ogres ogre)
+(define-monster troll 1.60 trolls troll)
+(define-monster vampire 5.00 vampires vampire)
+(define-monster dragon 9.00 dragons dragon)
+
+
+(define-rule (monster :distribution :weighted)
+ (1.00 *goblin*)
+ (1.00 *kobold*)
+ (1.00 *elf*)
+ (1.00 *dwarf*)
+ (1.00 *halfling*)
+ (1.00 *gnome*)
+ (1.00 *ogre*)
+ (1.00 *troll*)
+ (1.00 *gnoll*)
+ (0.10 *vampire*)
+ (0.01 *dragon*))
+
+
+;;;; Roles --------------------------------------------------------------------
+(define-rule role
+ "cleric"
+ "warrior"
+ "wizard"
+ "rogue")
+
+
+;;;; Elements -----------------------------------------------------------------
+(define-rule element
+ ("ice" "icy")
+ ("fire" "flaming")
+ ("electricity" "electrified")
+ ("poison" "venomous"))
+
+
+;;;; Armor --------------------------------------------------------------------
+(define-rule armor-piece
+ "scale mail"
+ "ring mail"
+ "chain mail"
+ "plate mail")
+
+(define-rule clothing-piece
+ "robe"
+ "shirt"
+ "pants"
+ "dress"
+ "skirt")
+
+
+(define-rule armor-enchantment
+ (:protection-from monster)
+ (:resistance element)
+ (:bonus bonus))
+
+(define-rule vanilla-armor
+ (metal armor-piece)
+ (textile clothing-piece))
+
+(define-rule (armor :distribution :weighted)
+ (2 (vanilla-armor nil))
+ (1 (vanilla-armor armor-enchantment)))
+
+
+(defgeneric enchanted-armor-description
+ (base enchantment-type enchantment-arguments))
+
+(defmethod enchanted-armor-description
+ (base (e (eql :protection-from)) enchantment-args)
+ (destructuring-bind (monster) enchantment-args
+ (format nil "~A of protection from ~A" base (monster-plural monster))))
+
+(defmethod enchanted-armor-description
+ (base (e (eql :resistance)) enchantment-args)
+ (destructuring-bind ((noun adjective)) enchantment-args
+ (declare (ignore adjective))
+ (format nil "~A of ~A resistance" base noun)))
+
+(defmethod enchanted-armor-description
+ (base (e (eql :bonus)) enchantment-args)
+ (destructuring-bind (val) enchantment-args
+ (format nil "+~D ~A" val base)))
+
+
+(defun vanilla-armor-description (vanilla-armor)
+ (destructuring-bind (material piece) vanilla-weapon
+ (format nil "~A ~A" (material-name material) piece)))
+
+
+(defun armor-description (armor)
+ (destructuring-bind (vanilla enchant) armor
+ (let ((vanilla-description (vanilla-armor-description vanilla)))
+ (if enchant
+ (enchanted-armor-description vanilla-description
+ (first enchant)
+ (rest enchant))
+ vanilla-description))))
+
+
+;;;; Weapons ------------------------------------------------------------------
+(define-rule melee-weapon
+ "dagger"
+ "longsword"
+ "short sword"
+ "hand axe"
+ "battleaxe"
+ "spear"
+ "halberd"
+ "scythe"
+ "scimitar"
+ "lance"
+ "hammer"
+ "staff"
+ "mace"
+ "flail")
+
+(define-rule (bow-weapon :distribution :weighted)
+ (2 "shortbow")
+ (2 "longbow")
+ (1 "crossbow")
+ (1 "compound bow"))
+
+
+(define-rule weapon-enchantment
+ (:slaying monster)
+ (:element element)
+ (:bonus bonus))
+
+
+(define-rule vanilla-weapon
+ (metal melee-weapon)
+ (wood bow-weapon))
+
+(define-rule (weapon :distribution :weighted)
+ (1 (vanilla-weapon nil))
+ (1 (vanilla-weapon weapon-enchantment)))
+
+
+(defgeneric enchanted-weapon-description
+ (base enchantment-type enchantment-arguments))
+
+(defmethod enchanted-weapon-description
+ (base (e (eql :slaying)) enchantment-args)
+ (destructuring-bind (monster) enchantment-args
+ (format nil "~A of ~A-slaying" base (monster-singular monster))))
+
+(defmethod enchanted-weapon-description
+ (base (e (eql :element)) enchantment-args)
+ (destructuring-bind (element) enchantment-args
+ (format nil "~A ~A" (second element) base)))
+
+(defmethod enchanted-weapon-description
+ (base (e (eql :bonus)) enchantment-args)
+ (destructuring-bind (val) enchantment-args
+ (format nil "+~D ~A" val base)))
+
+
+(defun vanilla-weapon-description (vanilla-weapon)
+ (destructuring-bind (material piece) vanilla-weapon
+ (format nil "~A ~A" (material-name material) piece)))
+
+
+(defun weapon-description (weapon)
+ (destructuring-bind (vanilla enchant) weapon
+ (let ((vanilla-description (vanilla-weapon-description vanilla)))
+ (if enchant
+ (enchanted-weapon-description vanilla-description
+ (first enchant)
+ (rest enchant))
+ vanilla-description))))
+
+
+;;;; Flavor -------------------------------------------------------------------
+(defparameter *monster* nil)
+
+(define-string sales-pitch
+ "Only used once!"
+ "Brand new!"
+ ("I bought it from" [(eval (monster-adjective (monster))) a] role :. ".")
+ "This is gonna go fast!")
+
+
+;;;; Main ---------------------------------------------------------------------
+(define-rule item
+ (eval (weapon-description (weapon)))
+ (eval (armor-description (armor))))
+
+(define-string offer
+ ("FOR SALE:" #\newline :.
+ [item cap] #\newline :.
+ sales-pitch))
+
+
+;;;; API ----------------------------------------------------------------------
+(defun random-string ()
+ (offer))
+
+
--- a/vendor/make-quickutils.lisp Tue Jan 17 11:08:42 2017 +0000
+++ b/vendor/make-quickutils.lisp Wed Jan 18 00:32:30 2017 +0000
@@ -4,6 +4,7 @@
"quickutils.lisp"
:utilities '(
+ :compose
:curry
:ensure-boolean
:ensure-gethash
@@ -12,6 +13,7 @@
:once-only
:rcurry
:read-file-into-string
+ :symb
:with-gensyms
:write-string-into-file
--- a/vendor/quickutils.lisp Tue Jan 17 11:08:42 2017 +0000
+++ b/vendor/quickutils.lisp Wed Jan 18 00:32:30 2017 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :N-GRAMS :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :WITH-GENSYMS :WRITE-STRING-INTO-FILE) :ensure-package T :package "MAGITEK.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :N-GRAMS :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :SYMB :WITH-GENSYMS :WRITE-STRING-INTO-FILE) :ensure-package T :package "MAGITEK.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "MAGITEK.QUICKUTILS")
@@ -14,11 +14,11 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
- :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH
- :ENSURE-LIST :TAKE :N-GRAMS :ONCE-ONLY
- :RCURRY :WITH-OPEN-FILE*
- :WITH-INPUT-FROM-FILE
- :READ-FILE-INTO-STRING
+ :COMPOSE :CURRY :ENSURE-BOOLEAN
+ :ENSURE-GETHASH :ENSURE-LIST :TAKE
+ :N-GRAMS :ONCE-ONLY :RCURRY
+ :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE
+ :READ-FILE-INTO-STRING :MKSTR :SYMB
:STRING-DESIGNATOR :WITH-GENSYMS
:WITH-OUTPUT-TO-FILE
:WRITE-STRING-INTO-FILE))))
@@ -46,6 +46,35 @@
(fdefinition function-designator)))
) ; eval-when
+ (defun compose (function &rest more-functions)
+ "Returns a function composed of `function` and `more-functions` that applies its ;
+arguments to to each in turn, starting from the rightmost of `more-functions`,
+and then calling the next one with the primary value of the last."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (funcall f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+ (define-compiler-macro compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "COMPOSE")))
+ `(let ,(loop for f in funs for arg in args
+ collect `(,f (ensure-function ,arg)))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+
(defun curry (function &rest arguments)
"Returns a function that applies `arguments` and the arguments
it is called with to `function`."
@@ -210,6 +239,23 @@
:while (= bytes-read buffer-size)))))))
+ (defun mkstr (&rest args)
+ "Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
+
+Extracted from _On Lisp_, chapter 4."
+ (with-output-to-string (s)
+ (dolist (a args) (princ a s))))
+
+
+ (defun symb (&rest args)
+ "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
+
+Extracted from _On Lisp_, chapter 4.
+
+See also: `symbolicate`"
+ (values (intern (apply #'mkstr args))))
+
+
(deftype string-designator ()
"A string designator type. A string designator is either a string, a symbol,
or a character."
@@ -281,8 +327,8 @@
(write-sequence string file-stream)))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(curry ensure-boolean ensure-gethash ensure-list n-grams once-only
- rcurry read-file-into-string with-gensyms with-unique-names
- write-string-into-file)))
+ (export '(compose curry ensure-boolean ensure-gethash ensure-list n-grams
+ once-only rcurry read-file-into-string symb with-gensyms
+ with-unique-names write-string-into-file)))
;;;; END OF quickutils.lisp ;;;;