src/robots/rpg-shopkeeper.lisp @ d5c110b938cb

(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-armor
    (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 scene
  ("images of" [monster monster-plural]))

(define-string sales-pitch
  "Only used once!"
  "Brand new!"
  ("I bought it from" [monster monster-adjective 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 #\newline :.
   sales-pitch))


;;;; API ----------------------------------------------------------------------
(defun random-string ()
  (offer))