Postawy. Przykład z DDD 164 lecz lekko obcięty dla możliwości napisania tego bardzo prosto. * TODO rozrzucić po plikach * Dorzucenie makr generujących część klas...

base.lisp

(defquery cergo-statu (cargo)
  (render-view :cergo-statu (cargo-history carg)))

(defcomand create-cargo (destination)
  (emit 'cargo-assumed
		:id (gen-id)
		:specyfiacation (make-delivery-specyfiaction destination)))

(defcomand shedule-carrier (form to cargo)
  (emit 'transport-sheduled :form form :to to :cargo cargo))

(defcomand start-carrier (shedule)
  (emit 'transport-start
		shedule
		(now)))

(defcomand end-carrier (shedule)
  (emit 'transport-end
		shedule
		(now)))

;;;Definicja encji, eventów i reduce'ow

(defgeneric apply-event (agregat event))

(defmethod apply-event (agregat event)
  agregat)

(defclass cargo ()
  ((id :initarg id
	   :accessor cargo-id)
   (history :initarg history
			:initform '()
			:accessor cargo-history)
   (specyfication :initarg specyfication
				  :acessor cargo-specyfication)))

(defclass cargo-event ()
  ((cargo-id :reader event-cargo
			 :initarg :cargo)))

(defclass cargo-assumed (cargo-event)
  ((specyfication :initarg specyfication)))

(defmethod apply-event ((agregat cargo) (event cargo-assumed))
  (make-cargo
   :id (event-id evnet)
   :history '()
   :specyfication (make-specyfication (event-destination event))))

(defclass carrier ()
  ((id carrier)
   (form :initarg form)
   (to :initarg to)
   (cargo :initarg cargo)
   (start :initform nil)
   (reached :initform nil)))

(defclass carrier-event ()
  ((carier-id :reader event-carier
			  :initarg cerrier)))

(defclass transport-sheduled (cargo-event cerrier-event)
  ((form :initarg form)
   (to :initarg to)))

(defmethod apply-event ((agregat carrier) (event transport-sheduled))
  (create-carier (event-cargo event) (event-from event) (event-to event)))

(defun add-carrier-to-history (cargo carrier-id)
  (make-cargo cargo :hostry (append (cargo-histor cargo) (find-carier-by-id carrier-id))))

(defmethod apply-event ((agregat cargo) (evnet transport-sheduled))
  (add-carrier-to-history cargo (carier-id event)))

(defclass transport-start (carrier-event)
  ((time :initarg time)))

(defmethod apply-event ((agregat cerrier) (event transport-start))
  (creat-carier carrier :start T))

(defclass transport-end (carrier-event)
  ((time :initarg time)))

(defmethod apply-event ((aggregat carrier) (event transport-end))
  (creat-carier carrier :reached T))