Refactor to make cooperative hacking nicer

7 files changed, 558 insertions, 0 deletions

diff --git a/src/game/abstract.lisp b/src/game/abstract.lisp
new file mode 100644
index 0000000..f54621e
--- /dev/null
+++ b/src/game/abstract.lisp
@@ -0,0 +1,47 @@
+;;;; abstract.lisp -- classes meant to be inherited
+
+(in-package :dnd)
+
+
+;;; PERSISTENT MIXINS
+(defclass has-uid ()
+  ((nuid :reader uid
+         :initform (nuid)
+         :index-type idx:string-unique-index
+         :index-reader object-with-uid))
+  (:metaclass db:persistent-class))
+
+(defclass can-equip ()
+  ((equipment-table
+    :initform nil
+    :type list
+    :documentation "A PLIST mapping 'equipment slots' to instances of LOOT. Equipment slots are things like :head, :torso, :left-ring, etc")
+   (equipment-slot-names
+    :initform +standard-humanoid-equipment+
+    :initarg :slot-names
+    :type (list keyword)
+    :documentation "The list of slots available to this entity."))
+  (:metaclass db:persistent-class))
+
+(defclass has-bag ()
+  ((bag
+    :reader bag
+    :initform nil
+    :type list
+    :documentation "A list of items that this entity is carrying."))
+  (:metaclass db:persistent-class))
+
+(defclass has-chronicle ()
+  ((chronicle :accessor chronicle :initform nil))
+  (:metaclass db:persistent-class)
+  (:documentation "A chronicle is a general purpose log of events."))
+
+(defparameter +standard-humanoid-equipment+
+  '(:head :neck :torso :waist :legs :feet :arms :left-fingers :right-fingers
+    :left-holding :right-holding :cloak)
+  "The equipment slots for standard humanoids")
+
+;;; ABSTRACT CLASSES
+(defclass game-object (db:store-object has-uid has-chronicle)
+  ()
+  (:metaclass db:persistent-class))
diff --git a/src/game/adventure.lisp b/src/game/adventure.lisp
new file mode 100644
index 0000000..801bc5e
--- /dev/null
+++ b/src/game/adventure.lisp
@@ -0,0 +1,261 @@
+;;;; adventure.lisp -- definition and functions operating on adventures
+
+(in-package :dnd)
+
+;;; MODEL CLASSES 
+
+(defclass adventure (game-object)
+  ((creator
+    :reader creator
+    :initarg :creator
+    :initform (error "adventures must have a creator")
+    :type player
+    :documentation "The player instance of the user who made this adventure.")
+   (seers
+    :accessor seers
+    :initarg :seers
+    :initform nil
+    :type (or nil (cons player))
+    :documentation "Seers are the people who peer out into their instruments of divination that heroes may go on quests.")
+   (title
+    :accessor title
+    :initarg :title
+    :initform (error "A adventure needs a title")
+    :type string)
+   (description
+    :accessor description
+    :initarg :description
+    :initform ""
+    :type string)
+   (rumors
+    :accessor rumors
+    :initform nil
+    :type (or nil (cons rumor))
+    :documentation "Beasts, Monsters, and Hazards rumored to be lurking about."))
+  (:metaclass db:persistent-class)
+  (:documentation "A adventure is a container of quests. Adventures are expected to be engaged with on a particular schedule, and are run by particular people."))
+
+
+(defclass rumor (game-object)
+  ((reporter
+    :reader reporter
+    :initarg :reporter
+    :type player
+    :documentation "The player who hast reported the vile rumor.")
+   (reported
+    :accessor reported 
+    :initform (error "A rumor must contain some reported matter")
+    :initarg :reported
+    :type string
+    :documentation "A description of the supposed peril that awaits heroes in a particular adventure."))
+  (:metaclass db:persistent-class)
+  (:documentation "Transcript of a rumor reported by some player related to a Adventure."))
+
+;;; HELPERS
+
+;;; QUERIES
+
+(defun player-adventures (player)
+  "Return a list of adventures one of the players' heroes is involved in."
+  (mapcar #'adventure (player-quests player) ))
+
+(defun adventure-heros (adventure &key (activep t))
+  "All the heros actively involved in this ADVENTURE. If ACTIVEP, then
+only the active quest(s) are considered, otherwise all quests are considered."
+  (remove-duplicates
+   (mapcan #'heroes-on-quest
+           (if activep
+               (remove-if-not #'quest-startedp (quests-in-adventure adventure))
+               (quests-in-adventure adventure)))))
+
+(defun all-adventures ()
+  (db:store-objects-with-class 'adventure))
+
+(defun adventures-visible-by (player)
+  (declare (ignore player))
+  (all-adventures))
+
+;;; TRANSACTIONS
+
+(defun create-adventure (player title &key (description "") seers)
+  (db:with-transaction ()
+    (make-instance 'adventure :title title :creator player
+                              :seers seers
+                              :description description)))
+
+(defun report-a-rumor (reporter adventure reported)
+  (db:with-transaction ()
+    (let ((rumor
+            (make-instance 'rumor
+                           :reported reported
+                           :reporter reporter)))
+      (push rumor (rumors adventure)))))
+
+(defun add-adventure-seer (player adventure)
+  (db:with-transaction ()
+    (push player (seers adventure))))
+
+
+;;; MODEL VIEWS
+
+(defrender :inline ((adventure adventure))
+  (with-html
+      (:a :href (urlpath adventure) (title adventure))))
+
+(defrender :option ((adventure adventure))
+  (with-html
+    (:option :value (uid adventure) (title adventure))))
+
+(defrender :list-item ((adventure adventure))
+  (render :inline adventure))
+
+
+
+
+;;; PAGES & PAGE CLASSES
+
+(defclass adventure-awaits ()
+  ((possible-seers
+    :reader possible-seers
+    :initarg :possible-seers
+    :initform nil)))
+
+
+(defrender t ((page adventure-awaits))
+  (with-page (:title "What sparkles in yer eye?")
+    (:h2 "Enscribe your new adventure in the book of the bards.")
+    (:div 
+     (:form
+      :method "POST" :action "/adventure-awaits" :id "new-adventure-form"
+      (:label
+       :for "TITLE"
+       "To sing of deeds, the bards require a title equal in greatness to the adventure before you.")
+      (:br)
+      (:input :name "TITLE"
+              :minlength "2"
+              :maxlength "40"
+              :placeholder "Dungeons & Deadlines")
+      (when (possible-seers page)
+        (:br)
+        (:label
+         :for "SEERS"
+         "Who may act as a seer on this adventure?")
+        (:br)
+        (render :checkboxes (possible-seers page)))
+      
+      (:h4 "Describe the adventure you're about to begin:")
+      (:textarea  :name "DESCRIPTION" :rows "5" :cols "60")
+      (:br)
+      (:button :type "submit" "Embark!")))))
+
+
+(defclass adventure-page ()
+  ((adventure :reader adventure :initarg :adventure)
+   (player :reader player :initarg :player)))
+
+(defrender t ((page adventure-page))
+  (let ((adventure (adventure page)))
+    (with-page (:title (title adventure))
+      (:h1 (title adventure))
+      (:p (description adventure))
+      (:h2 "Rumors: ")
+					; (render :list (rumors adventure))
+      (:h2 "Architect of this Adventure: " (nickname (creator adventure)))
+      (:h2 "Seers: ")
+      (render :list (seers adventure))
+      (:form :method "POST" :action (urlpath adventure)
+             (:label :for "SEER" "Add a seer to this adventure:") (:br)
+             (:select :name "SEER"
+                      (loop :for p :in (all-other-players (player page))
+                            :collect (:option :value (nickname p) (nickname p))))
+             (:button :type "submit" "Add Seer")))))
+
+(defclass spymaster ()
+  ((player :reader player :initarg :player)
+   (adventures :reader adventures :initarg :adventures)))
+
+
+(defrender t ((page spymaster))
+  (with-page (:title "spymaster - report a rumor")
+    (:h1 "Of what hazards have ye heard rumor?")
+    (:form :method "POST" :action "/spymaster"
+           (:label :for "ADVENTURE" "What adventure did ye hear a rumor about?")
+           (:br)
+           (render :select (adventures page) :name "ADVENTURE")
+           (:br)
+           (:label :for "REPORTED" "And what did ye have to report?")
+           (:br)
+           (:textarea :name "REPORTED" :rows "5" :cols "60")
+           (:br)
+           (:button :type "submit" "Report!"))))
+
+
+;;; ENDPOINT HELPERS
+(define-id-plucker adventure)
+
+
+;;; ENDPOINT DEFINITIONS
+
+(defendpoint* :get "/tavern/adventures" () ()
+  (with-session (me)
+    (render (page-render-mode)
+            (make-instance 'tavern-adventures
+                           :your-adventures (adventures-visible-by me)))))
+
+
+
+
+
+(defendpoint* :get "/adventure-awaits" () ()
+  (with-session (player)
+    (render (page-render-mode)
+            (make-instance 'adventure-awaits
+                           :possible-seers (remove player (all-players))))))
+
+(defendpoint* :post "/adventure-awaits" () ()
+  (with-session (creator)
+    (with-plist ((title :title) (description :description)) (lzb:request-body)
+      (let ((possible-seers
+              (loop :for (key val) :on (lzb:request-body) :by #'cddr
+                    :when (string-equal key "POSSIBLE-SEER")
+                      :collect (object-with-uid val))))
+        (redirect-to
+         (urlpath
+          (create-adventure creator title
+                            :description description
+                            :seers possible-seers)))))))
+
+
+(defendpoint* :get "/spymaster" () ()
+  (with-session (player)
+    (render (page-render-mode)
+            (make-instance 'spymaster
+                           :player player
+                           :adventures (adventures-visible-by player)))))
+
+
+(defendpoint* :post "/spymaster" () ()
+  (with-session (player)
+    (with-plist ((adventure :adventure) (reported :reported)) (lzb:request-body)
+      (let ((adventure (an-adventure-with-id adventure)))
+        (report-a-rumor player adventure reported))
+      (redirect-to "/tavern"))))
+
+;; NB for current hackers (Tue Mar  7 06:44:02 PM PST 2023)
+;; Even though these next three all look the same I'm not going to
+;; make a macro to generate them. there may be future concerns with
+;; permissions or query parameters that will make them look different.
+
+(defendpoint* :get "/adventure/:adventure an-adventure-with-id:/:title:" () ()
+  (with-session (player)
+    (render (page-render-mode)
+            (make-instance 'adventure-page
+                           :player player
+                           :adventure adventure)))) ;; for now, render raw adventure.
+
+(defendpoint* :post "/adventure/:adventure an-adventure-with-id:/:title:" () ()
+  (with-session (player)
+    (with-plist ((seer :seer)) (lzb:request-body)
+      (when (player-with-nick seer)
+	(add-adventure-seer (player-with-nick seer) adventure))
+      (redirect-to (urlpath adventure)))))
diff --git a/src/game/hazard.lisp b/src/game/hazard.lisp
new file mode 100644
index 0000000..c6ad58d
--- /dev/null
+++ b/src/game/hazard.lisp
@@ -0,0 +1,28 @@
+(in-package :dnd)
+
+(defclass hazard (game-object)
+  ((quest
+    :accessor quest-of
+    :index-type idx:hash-index
+    :index-reader hazards-in-quest
+    :documentation "The quest to which this hazard belongs. Initially it is unbound. It becomes boudn when the hazard is added to a quest.")
+   (description
+    :accessor description
+    :initarg :description
+    :initform ""
+    :type string
+    :documentation "")
+   (overcomep
+    :accessor is-overcome
+    :initform nil
+    :documentation "indicates whether or not this hazard has been overcome.")
+   (imminence
+    :accessor imminence-of
+    :type priority
+    :documentation "")
+   (menace ;; difficulty
+    :accessor menace-of
+    :type integer
+    :documentation "How dangerous the hazard is." ))
+  (:metaclass db:persistent-class)
+  (:documentation "Hazard is a superclass for all hazards encountered in a quest.  It's chronicle includes data about which heroes fought and which overcame."))
diff --git a/src/game/hero.lisp b/src/game/hero.lisp
new file mode 100644
index 0000000..68606b2
--- /dev/null
+++ b/src/game/hero.lisp
@@ -0,0 +1,123 @@
+;;;; hero.lisp -- code related to heros
+
+(in-package :dnd)
+
+;;; MODEL CLASSES
+
+(deftype title ()
+  `(member :noob))
+
+(deftype character-class ()
+  `(member :hero))
+
+(deftype priority ()
+  `(member :low :medium :high))
+
+(defun hero-class (h)
+  "barGaryan")                          ; TODO: real implementation
+
+(defun hero-title (h)
+  "Scouse Chef")                        ; TODO: real implementation
+
+(defun renown (hero)
+  (experience hero))                    ; TODO: real implementaiton
+
+
+(defclass hero (game-object has-bag can-equip)
+  ((name
+    :accessor name
+    :initarg :name
+    :initform (error "Heroes must be named")
+    :type string
+    :index-type idx:string-unique-index
+    :index-reader hero-known-as)
+   (player
+    :reader player
+    :initarg :player
+    :type player
+    :index-type idx:hash-index
+    :index-reader player-heroes)
+   (quest
+    :accessor quest
+    :initarg :quest
+    :initform nil
+    :type (or nil quest)
+    :documentation "The quest that this hero is on. A hero may be on only one quest at a time."))
+  (:metaclass db:persistent-class))
+
+(defmethod adventure ((hero hero))
+  (a:when-let (quest (quest hero))
+    (adventure quest)))
+
+;;; HELPERS
+
+;;; QUERIES
+(defun all-heroes ()
+  (db:store-objects-with-class 'hero))
+
+;;; TRANSACTIONS
+
+(defun birth-from-the-goddess-loins (player name)
+  (db:with-transaction ()
+    (make-instance 'hero :name name :player player)))
+
+;;; MODEL VIEWS
+
+(defrender :list-item ((hero hero))
+  (with-html
+      (:p
+       (render :link-to hero)
+       (a:when-let (quest (quest hero))
+                   (:span  "who's quest is to")
+                   (:span (render :link-to quest))))))
+
+
+(defrender :link-to ((hero hero))
+  (with-html
+    (:a :href (urlpath hero)
+        (unique-name hero) "the" (hero-class hero) (hero-title hero))))
+
+;;; PAGES & PAGE CLASSES
+
+(defclass hero-page ()
+  ((hero :reader hero :initarg :hero)
+   (player :reader player :initarg :player)))
+
+(defrender t ((page hero-page))
+  (with-page (:title (unique-name (hero page)))
+    (:h1 (unique-name (hero page)))
+    (:p "uhhh.....")))
+
+(defrender t ((page (eql :goddess-shrine))) 
+  (with-page (:title "A Sacred Shrine")
+    (:header
+     (:h1 "Pray and become a hero..."))
+    (:form :method "POST" :action "/goddess-shrine"
+	   (:label :for "NAME" "Enter the epithet by which the ages shall know thy hero:")
+	   (:input :name "NAME")
+	   (:button :type "submit" "Pray To The Goddess"))))
+
+
+;;; ENDPOINT HELPERS
+
+(define-id-plucker hero)
+
+;;; ENDPOINT DEFINITIONS 
+
+(defendpoint* :get "/goddess-shrine" () ()
+  (with-session (player)
+    (render (page-render-mode) :goddess-shrine)))
+
+(defendpoint* :post "/goddess-shrine" () ()
+  (with-session (player)
+    (with-checked-plist ((name :name 'a-short-string)) (lzb:request-body)
+      (birth-from-the-goddess-loins player name)
+      (redirect-to "/tavern"))))
+
+
+(defendpoint* :get "/hero/:hero a-hero-with-id:/:name:" () ()
+  (with-session (player)
+    (render (page-render-mode)
+            (make-instance 'hero-page
+                           :player player
+                           :hero hero))))
diff --git a/src/game/quest.lisp b/src/game/quest.lisp
new file mode 100644
index 0000000..ed9a5b4
--- /dev/null
+++ b/src/game/quest.lisp
@@ -0,0 +1,51 @@
+(in-package :dnd)
+
+(defclass quest (game-object)
+  ((adventure
+    :reader adventure
+    :initarg :adventure
+    :initform (error "No quest can fall outside the scope of a adventure.")
+    :type adventure
+    :index-type idx:hash-index 
+    :index-reader quests-in-adventure
+    :documentation "The adventure to which this quest belongs")
+   (name
+    :accessor name
+    :initarg :name
+    :type string
+    :initform (format nil "~a" (gensym "QUEST")))
+   (horizon-of-hope
+    :accessor horizon-of-hope
+    :initarg :deadline
+    :type integer
+    :initform nil
+    :documentation "When all hope becomes lost.")
+   (inception
+    :accessor quest-inception
+    :initform nil
+    :type (or nil integer)
+    :documentation "Time at which the quest began."))
+  (:metaclass db:persistent-class)
+  (:documentation "A collection of hazards with a deadline and start date which heroes will attack."))
+
+
+
+(defun player-quests (player)
+  "Return all quests in which one of player's heroes is engaged."
+  (remove nil (mapcar #'quest (player-heroes player))))
+
+(define-id-plucker quest)
+
+
+(defrender :link-to ((quest quest))
+  (with-html
+    (:a :href (urlpath quest)
+        (name quest))))
+
+(defclass quest-page ()
+  ((quest :reader quest :initarg :quest)
+   (player :reader player :initarg :player)))
+
+(defrender t ((page quest))
+  (with-page (:title (unique-name (quest page )))
+    (:h1 (unique-name (quest page)))))
diff --git a/src/game/rumor.lisp b/src/game/rumor.lisp
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/src/game/rumor.lisp
diff --git a/src/game/tavern.lisp b/src/game/tavern.lisp
new file mode 100644
index 0000000..25d6ef0
--- /dev/null
+++ b/src/game/tavern.lisp
@@ -0,0 +1,48 @@
+;;;; pages/tavern.lisp -- enter the tavern 
+
+(in-package :dnd)
+
+(defclass/std tavern ()
+  ((player)))
+
+(defrender t ((tavern tavern))
+  (with-page (:title "A Bustling Tavern")
+      (let ((player (player tavern)))
+        (render :details player)
+        (when (player-heroes player)
+          (:h2 "Your Heroes:")
+          (render :list (player-heroes player)))
+        (:a :href "tavern/adventures"  "Adventures for which you are seer.")
+        (:br)
+        (:a :href "/goddess-shrine" "Pray a new hero rises.")
+        (:br)
+        (:a :href "/spymaster" "Report a Roguish Rumour...")
+        (:br)
+        (:a :href "/adventure-awaits" "Embark on a new Adventure!"))))
+
+
+(defclass/std tavern-adventures ()
+  ((your-adventures)))
+
+(defrender t ((page tavern-adventures))
+  (with-page (:title "Your Adventures")
+    (:h1 "You are seer on the following adventures")
+    (render :list (your-adventures page))))
+
+(defendpoint* :get "/tavern" () ()
+  (with-session (me)
+    (render (page-render-mode)
+            (make-instance 'tavern :player me))))
+
+
+
+
+(defendpoint* :get "/quest/:quest a-quest-with-id:/:name:" () ()
+  (with-session (player)
+    (render (page-render-mode)
+            (make-instance 'quest-page
+                           :player player
+                           :hero quest))))
+
+
+