Permalink
Browse files

making progress with body layers

  • Loading branch information...
1 parent b357635 commit a962af25856cc8e8d5d95048f3e2c5ef8e10f0a3 @flyingmachine committed Apr 19, 2012
Showing with 79 additions and 54 deletions.
  1. +36 −13 body-classes.lisp
  2. +39 −41 body-data.lisp
  3. +4 −0 common.lisp
View
@@ -111,6 +111,9 @@
(defproxy body-part prototype damage-descriptions)
(defproxy body-part prototype targeting-weight)
+;; ---
+;; body layers
+;; ---
(defclass body-layer ()
((body-parts
:documentation "The body parts for this layer"
@@ -126,6 +129,12 @@
:initarg :base
:reader base)))
+(defun make-body-layer (body-parts height base)
+ (make-instance 'body-layer
+ :body-parts body-parts
+ :height height
+ :base base))
+
;; ---
;; bodies
;; ---
@@ -144,24 +153,38 @@
(mapcan #'body-parts (body-layers body)))
(defun make-body (template-name &optional (scale 1))
- (make-instance 'body
- :body-layers (compose-parts-from-template template-name)
- :scale scale))
-
-;; TODO comopose layers from template
-;; TODO compose parts from layers
-(defun compose-parts-from-template (template-name)
+ (let ((template (gethash template-name *body-templates*)))
+ (make-instance 'body
+ :body-layers (create-layers-for-body template
+ (create-parts-from-prototype-pairs (mapcan #'third template) *body-part-prototypes*))
+ :scale scale)))
+
+(defun create-layers-from-template (template body-parts)
+ (labels ((compose (layers acc)
+ (if (consp layers)
+ (let* ((layer (car layers))
+ (layer-name (first layer))
+ (height (second layer))
+ (body-part-names (mapcar #'cdr (third layer))))
+ (compose
+ (cdr layers)
+ (cons acc (cons layer-name (make-body-layer (parts-for-layer body-part-names body-parts) height (cdr (last acc)))))))
+ acc)))
+ (compose template nil)))
+
+(defun create-parts-from-prototype-pairs (prototype-pairs prototype-set)
(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*)))
+ (make-body-part (gethash (car prototype-pair) prototype-set) (cdr prototype-pair)))
+ prototype-pairs))
+
+;; TODO refactor out this test function?
+(defun parts-for-layer (body-part-names body-parts)
+ (remove-if-not (lambda (name) (position name body-part-names)) body-parts :key #'name))
(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)))))
+ (cons body-part (targeting-weight (prototype body-part))))
(body-parts body)))
View
@@ -25,45 +25,43 @@
(defun make-body-template (name &rest layers)
(setf (gethash name *body-templates*) layers))
+(defun make-body-layer-template (name height &rest prototype-pairings)
+ (list name height (mapcan (lambda (pairing)
+ (if (consp pairing)
+ (mapcar (lambda (name)
+ (cons (car pairing) name))
+ (cdr pairing))
+ (list (cons pairing (mkstr pairing)))))
+ prototype-pairings)))
+
(make-body-template 'humanoid
- '(head
- 26
- '((eye . "left eye")
- (eye . "right eye")
- (head)
- (neck)
- (jugular)
- (wind-pipe)))
- '(torso
- 65
- '((shoulder . "left shoulder")
- (shoulder . "right shoulder")
- (upper-arm . "left upper arm")
- (upper-arm . "right upper arm")
- (forearm . "left forearm")
- (forearm . "right forearm")
- (chest)
- (abdomen)
- (back)
- (kidney . "left kidney")
- (kidney . "right kidney")))
- '(pelvis
- 13
- '((junk)
- (ass)))
- '(upper-leg
- 52
- '('(femoral-artery . "left femoral artery")
- '(femoral-artery . "right femoral artery")
- '(thigh . "left thigh")
- '(thigh . "right thigh")))
- '(lower-leg
- 39
- '('(lower-leg . "left lower leg")
- '(lower-leg . "right lower leg")
- '(achilles . "left achilles")
- '(achilles . "right achilles")))
- '(foot
- 13
- '('(foot . "left foot")
- '(foot . "right foot"))))
+ (make-body-layer-template 'foot 13
+ '(foot "left foot" "right foot"))
+
+ (make-body-layer-template 'lower-leg 39
+ '(lower-leg "left lower leg" "right lower leg")
+ '(achilles "left achilles" "right achilles"))
+
+ (make-body-layer-template 'upper-leg 52
+ '(femoral-artery "left femoral artery" "right femoral artery")
+ '(thigh "left thight" "right thigh"))
+
+ (make-body-layer-template 'pelvis 13
+ 'junk
+ 'ass)
+
+ (make-body-layer-template 'torso 65
+ '(shoulder "left shoulder" "right shoulder")
+ '(upper-arm "left upper arm" "right upper arm")
+ '(forearm "left forearm" "right forearm")
+ 'chest
+ 'abdomen
+ 'back
+ '(kidney "left kidney" "right kidney"))
+
+ (make-body-layer-template 'head 26
+ '(eye "left eye" "right eye")
+ 'head
+ 'neck
+ 'jugular
+ 'wind-pipe))
View
@@ -5,6 +5,10 @@
(defparameter *damage-set-types* '(1h 2h thrown))
;; create a damage hash
+;;
+;; create a hash table, then set its keys using the global
+;; *damage-types* list
+;; TODO make a macro so that I don't have to list the keys?
(defun make-damage (default &key slice blunt pierce fire ice)
(macrolet ((setter ()
`(progn

0 comments on commit a962af2

Please sign in to comment.