Seems to be working

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)))