diff options
-rw-r--r-- | map.svg | 20 | ||||
-rw-r--r-- | rooms.lisp | 52 |
2 files changed, 72 insertions, 0 deletions
diff --git a/map.svg b/map.svg new file mode 100644 index 0000000..7d47f2d --- /dev/null +++ b/map.svg @@ -0,0 +1,20 @@ +<?xml version="1.0" standalone="no"?> +<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" + "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> +<svg viewbox="0 0 200 200" width="200" height="200" version="1.1" id="toplevel" + xmlns="http://www.w3.org/2000/svg" + xmlns:xlink="http://www.w3.org/1999/xlink"> + <title> + Floorplan + </title> + <rect x="5" y="5" width="100" height="50" fill="none" stroke="black" + stroke-width="1"/> + <rect x="5" y="5" width="20" height="20" fill="none" stroke="black" + stroke-width="1"/> + <rect x="5" y="15" width="20" height="40" fill="none" stroke="black" + stroke-width="1"/> + <rect x="10" y="5" width="5" height="5" fill="none" stroke="black" + stroke-width="1"/> + <rect x="15" y="5" width="5" height="10" fill="none" stroke="black" + stroke-width="1"/> +</svg> diff --git a/rooms.lisp b/rooms.lisp new file mode 100644 index 0000000..9fb2a3e --- /dev/null +++ b/rooms.lisp @@ -0,0 +1,52 @@ +(ql:quickload 'cl-svg) + +(defpackage #:inv (:use :cl) (:export #:main)) +(in-package :inv) + +(defmacro define-area-class (name &rest slots) + `(defclass ,name () + ,(loop for slot in slots + collect `(,slot :initarg ,(intern (string-upcase (symbol-name slot)) :keyword) + :initform (error "please provide a value for ~a" ',slot) + :accessor ,(intern (concatenate 'string (symbol-name name) + "-" + (symbol-name slot))))))) + +(define-area-class area name x y width height subs) + +(defmacro are (name x y width height &optional subs) + `(make-instance 'area :name ,name :x ,x :y ,y :width ,width :height ,height :subs ,subs)) + +(defmethod print-object ((obj area) out) + (print-unreadable-object (obj out :type t) + (format out "name:~s x:~d y:~d subs:~d" + (area-name obj) (area-x obj) (area-y obj) (length (area-subs obj))))) + +(defun draw-room-with-subs (scene area offset-x offset-y) + (if area + (svg:draw scene + (:rect :x (+ offset-x (area-x area)) + :y (+ offset-y (area-y area)) + :width (area-width area) + :height (area-height area) + :fill "none" :stroke "black" :stroke-width 1))) + (if area + (loop for sub in (area-subs area) + do (draw-room-with-subs scene sub + (area-x area) (area-y area))))) + +; define the floorplan here +; do note: sub-room locations are relative to their parent +(defparameter floorplan + (are "main" 5 5 100 50 + (list (are "room-1" 0 0 20 20 '()) + (are "room-2" 0 10 20 40 '()) + (are "room-3" 5 0 5 5 '()) + (are "room-4" 10 0 5 10 '())))) + +(let ((scene (svg:make-svg-toplevel 'svg:svg-1.1-toplevel :height 200 :width 200 + :viewbox "0 0 200 200"))) + (svg:title scene "Floorplan") + (draw-room-with-subs scene floorplan 0 0) + (with-open-file (s #p"map.svg" :direction :output :if-exists :supersede) + (svg:stream-out s scene))) |