Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

finished updating bodies

  • Loading branch information...
commit 23494b67638f40679a269cb02d83783d55a2cf7e 1 parent 15c2754
@flyingmachine authored
View
52 body-classes.lisp
@@ -35,15 +35,8 @@
;; This isn't really prototypal in the way that javascript is
;; prototypal because ultimately we don't "shadow" any variables
-
-;; TODO separate name from identifier?
(defclass body-part-prototype ()
- ((name
- :documentation "Name of body part, e.g. head, foot, etc"
- :initarg :name
- :reader name)
-
- (targeting-weight
+ ((targeting-weight
:documentation "How likely it is to hit this body part relative to other body parts"
:initarg :targeting-weight
:reader targeting-weight)
@@ -54,6 +47,14 @@
:reader damage-descriptions
:initform *default-damage-descriptions*)))
+(defun make-body-part-prototype (name &key targeting-weight (damage-descriptions *default-damage-descriptions*))
+ (setf (gethash name *body-part-prototypes*)
+ (make-instance 'body-part-prototype
+ :targeting-weight targeting-weight
+ :damage-descriptions damage-descriptions)))
+
+
+;; body part
(defclass body-part ()
((prototype
:initarg :prototype
@@ -73,6 +74,20 @@
:prototype prototype
:name name))
+(defgeneric modify-damage (game-object damage-type modification)
+ (:documentation "Adds 'modification' to the damage type of a damage object associated with a game object"))
+
+(defmethod modify-damage ((body-part body-part) damage-type modification)
+ (incf (damage-for (damage-received body-part) damage-type) modification))
+
+;; TODO create 'proxy' macro?
+(defmethod damage-descriptions ((body-part body-part))
+ (damage-descriptions (prototype body-part)))
+
+(defmethod targeting-weight ((body-part body-part))
+ (targeting-weight (prototype body-part)))
+
+;; bodies
(defclass body ()
((body-parts
:initarg :body-parts
@@ -83,3 +98,24 @@
:initarg :scale
:initform 1
:reader scale)))
+
+(defun make-body (template-name &optional (scale 1))
+ (make-instance 'body
+ :body-parts (compose-parts-from-template template-name)
+ :scale scale))
+
+(defun compose-parts-from-template (template-name)
+ (mapcar (lambda (prototype-pair)
+ (let ((prototype (gethash (car prototype-pair) *body-part-prototypes*)))
+ (if (cdr prototype-pair)
+ (make-body-part prototype (cdr prototype-pair))
+ (make-body-part prototype (string-downcase (mkstr (car prototype-pair)))))))
+ (gethash template-name *body-templates*)))
+
+(defun body-part (body part-name)
+ (find part-name (body-parts body) :key #'name :test #'equal))
+
+(defun body-part-targeting-weights (body)
+ (mapcar (lambda (body-part)
+ (cons body-part (targeting-weight (prototype (body-part)))))
+ (body-parts body)))
View
28 body-data.lisp
@@ -1,12 +1,6 @@
-;; TODO
-(defparameter *body-part-prototypes* make-hash-table)
-(defparameter *body-templates* make-hash-table)
-(defun make-body-part-prototype (name &key length base-body-part targeting-weight damage-descriptions)
- (setf (gethash name *body-part-prototypes*)
- (make-instance 'body-part-prototype
- :name name
- :targeting-weight targeting-weight
- :damage-descriptions damage-descriptions)))
+;; TODO read this data from CSV files
+(defparameter *body-part-prototypes* (make-hash-table))
+(defparameter *body-templates* (make-hash-table))
(make-body-part-prototype 'eye :targeting-weight 1)
(make-body-part-prototype 'head :targeting-weight 3)
@@ -53,23 +47,11 @@
'(ass)
'(femoral-artery . "left femoral artery")
'(femoral-artery . "right femoral artery")
- '(thigh . "left thight")
- '(thigh . "right thight")
+ '(thigh . "left thigh")
+ '(thigh . "right thigh")
'(lower-leg . "left lower leg")
'(lower-leg . "right lower leg")
'(achilles . "left achilles")
'(achilles . "right achilles")
'(foot . "left foot")
'(foot . "right foot"))
-
-(defun make-body (template-name &optional (scale 1))
- (make-instance 'body
- :body-parts (compose-parts-from-template template-name)
- :scale scale))
-
-(defun compose-parts-from-template (template-name)
- (mapcar (lambda (prototype-name)
- (if (cdr prototype-name)
- (make-body-part (car prototype-name) (cdr prototype-name))
- (make-body-part (car prototype-name) (car prototype-name))))
- (gethash template-name *body-templates*)))
View
31 combat.lisp
@@ -4,17 +4,18 @@
(apply-damage attacker defender weapon thing-hit)
(format t "You missed! How sad.~%"))))
+;; Target is a specific body part
(defun attempt-hit (attacker defender weapon &optional target)
- (let* ((body-part-weights (symmetrize-body-parts *asym-humanoid-body-parts*))
- (miss (= (random 10) 0)))
+ (let ((miss (= (random 10) 0)))
(unless miss
- (car (select-target body-part-weights)))))
+ (select-target (body-parts defender)))))
-(defun apply-damage (attacker defender weapon thing-hit)
- (let ((body-part (assocdr thing-hit (body-parts defender)))
- (weapon-damage (active-damage-set weapon)))
+(defun apply-damage (attacker defender weapon body-part)
+ (let ((weapon-damage (active-damage-set weapon)))
(mapc (lambda (damage-type)
- (incf (damage-for (damage-received body-part) damage-type) (random-damage (damage-for weapon-damage damage-type))))
+ (modify-damage body-part
+ damage-type
+ (random-damage (damage-for weapon-damage damage-type))))
*damage-types*)))
;; will probably end up making this more general
@@ -24,3 +25,19 @@
(1 1)
(2 (1+ (random 2)))
(otherwise (+ (1+ (floor (/ base-damage 2))) (random (ceiling (/ base-damage 2)))))))
+
+;;---
+;; Targeting
+;;---
+(defun body-part-sum (body-parts)
+ (reduce #'+ body-parts :key #'targeting-weight))
+
+(defun select-target (body-parts)
+ (nth (position (random (body-part-sum body-parts)) body-parts :key #'targeting-weight :test (target-hit-function)) body-parts))
+
+;; wonder if it's good style to include "function" when returning function
+(defun target-hit-function ()
+ (let ((current-position 0))
+ (lambda (target increment)
+ (incf current-position increment)
+ (> current-position target))))
View
2  common.lisp
@@ -1,7 +1,7 @@
;; ---
;; Damage
;; ---
-(defparameter *damage-types* '(slice blunt pierce fire ice poison))
+(defparameter *damage-types* '(slice blunt pierce fire ice))
(defparameter *damage-set-types* '(1h 2h thrown))
;; create a damage hash
View
9 describe-body.lisp
@@ -11,7 +11,7 @@
;; Returns a list of all descriptions that apply based on each kind of
;; damage done
(defmethod describe-damage ((body-part body-part))
- (let ((descriptions (append (custom-damage-descriptions body-part) (damage-descriptions body-part)))
+ (let ((descriptions (damage-descriptions body-part))
(body-part-damage (damage-received body-part)))
(remove nil (mapcar (lambda (damage-type)
(let ((descriptions-for-type (damage-for descriptions damage-type)))
@@ -37,7 +37,7 @@
(defmethod describe-game-object ((body body))
- (remove nil (mapcan (lambda (body-part) (describe-game-object (cdr body-part))) (body-parts body))))
+ (remove nil (mapcan (lambda (body-part) (describe-game-object body-part)) (body-parts body))))
(defun look (game-object)
@@ -48,8 +48,3 @@
(formatted-output r (1+ level))
(format t "~v{ ~}~a~%" level '(foo) r))) l)))
(mapc (lambda (d) (formatted-output d 0)) description))))
-
-(defun body-part (body part-name)
- (cdr (assoc part-name (body-parts body))))
-
-
View
2  master.lisp
@@ -1,7 +1,7 @@
(load 'utilities)
(load 'common)
(load 'target)
-(load 'bodies)
+(load 'body-classes)
(load 'body-data)
(load 'describe-body)
(load 'items)
View
51 target.lisp
@@ -1,51 +0,0 @@
-(defparameter *asym-humanoid-body-parts*
- '((head . 3)
- (left-eye . 1)
- (left-ear . 1)
- (mouth . 1)
- (nose . 1)
- (neck . 2)
- (jugular . 1)
- (wind-pipe . 1)
- (left-shoulder . 3)
- (left-upper-arm . 3)
- (chest . 10)
- (back . 10)
- (left-forearm . 3)
- (abdomen . 6)
- (left-kidney . 1)
- (left-hand . 2)
- (junk . 3)
- (ass . 4)
- (left-femoral-artery . 2)
- (left-knee . 2)
- (left-thigh . 4)
- (left-lower-leg . 3)
- (left-achilles . 1)
- (left-foot . 2)))
-
-(defun symmetrize-body-parts (body-parts)
- (labels ((part-and-match (part acc)
- (let ((part-string (string-downcase (symbol-name (car part)))))
- (append acc
- (list part)
- (when (search "left" part-string)
- (list (cons (intern (string-upcase (concatenate 'string "right" (subseq part-string 4)))) (cdr part)))))))
- (add-matching-parts (parts acc)
- (if (null parts)
- acc
- (add-matching-parts (cdr parts) (part-and-match (car parts) acc)))))
- (add-matching-parts body-parts nil)))
-
-(defun body-part-sum (body-parts)
- (reduce #'+ body-parts :key #'cdr))
-
-(defun select-target (body-parts)
- (nth (position (random (body-part-sum body-parts)) body-parts :key #'cdr :test (target-hit-function)) body-parts))
-
-;; wonder if it's good style to include "function" when returning function
-(defun target-hit-function ()
- (let ((current-position 0))
- (lambda (target increment)
- (incf current-position increment)
- (> current-position target))))
View
54 tests.lisp
@@ -1,25 +1,55 @@
+;; From Practical Common Lisp, ch. 9
+(defvar *test-name* nil)
+
+(defmacro deftest (name parameters &body body)
+ "Define a test function. Within a test function we can call
+ other test functions or use 'check' to run individual test
+ cases."
+ `(defun ,name ,parameters
+ (let ((*test-name* (append *test-name* (list ',name))))
+ ,@body)))
+
+(defmacro check (&body forms)
+ "Run each expression in 'forms' as a test case."
+ `(combine-results
+ ,@(loop for f in forms collect `(report-result ,f ',f))))
+
+(defmacro combine-results (&body forms)
+ "Combine the results (as booleans) of evaluating 'forms' in order."
+ (with-gensyms (result)
+ `(let ((,result t))
+ ,@(loop for f in forms collect `(unless ,f (setf ,result nil)))
+ ,result)))
+
+(defun report-result (result form)
+ "Report the results of a single test case. Called by 'check'."
+ (format t "~:[FAIL~;pass~] ... ~a: ~a~%" result *test-name* form)
+ result)
+
+
(defun test-body-part ()
- (let ((body-part (make-instance 'body-part :name 'head)))
- (setf (damage-for (damage-received body-part) 'slice) 20)
- (setf (damage-for (damage-received body-part) 'blunt) 90)
+ (let* ((body-part-prototype (make-body-part-prototype 'test-head :targeting-weight 10))
+ (body-part (make-body-part body-part-prototype "head")))
+ (modify-damage body-part 'slice 20)
+ (modify-damage body-part 'blunt 90)
(describe-game-object body-part)))
(defun test-body ()
- (let ((body (make-instance 'humanoid-body)))
- (setf (damage-for (damage-received (body-part body 'neck)) 'slice) 20)
- (setf (damage-for (damage-received (body-part body 'left-eye)) 'pierce) 90)
- (setf (damage-for (damage-received (body-part body 'left-eye)) 'blunt) 90)
- (setf (damage-for (damage-received (body-part body 'right-thigh)) 'blunt) 30)
+ (let ((body (make-body 'humanoid)))
+ (modify-damage (body-part body "neck") 'slice 20)
+ (modify-damage (body-part body "left eye") 'pierce 90)
+ (modify-damage (body-part body "left eye") 'blunt 90)
+ (modify-damage (body-part body "right thigh") 'blunt 30)
(describe-game-object body)
(look body)))
(defun test-attack ()
- (let ((attacker (make-instance 'humanoid-body))
- (defender (make-instance 'humanoid-body))
+ (let ((attacker (make-body 'humanoid))
+ (defender (make-body 'humanoid))
(weapon (select-item "dagger")))
(attack attacker defender weapon)
(look defender)))
-(setq giant (make-instance 'humanoid-body))
-(setq hobbit (make-instance 'humanoid-body))
+(setq giant (make-body 'humanoid))
+(setq hobbit (make-body 'humanoid))
(setq dagger (select-item "dagger"))

0 comments on commit 23494b6

Please sign in to comment.
Something went wrong with that request. Please try again.