(uiop:define-package :monasticlisp
    (:mix :clim :clim-lisp :cl)
  (:export #:blueprint #:blueprint-frame #:*fr*
	   #:+pt #:*pt #:-pt #:+pl #:-pl
	   #:com-opp #:res
	   #:walls #:pillars #:scale #:opposite-day)
  (:import-from #:bordeaux-threads)
  (:nicknames :nast))

(in-package :monasticlisp)



(setf (documentation '*fr* 'variable)
      "The blueprint-frame in *fr* is the target of all the repl convenience functions. *fr* should be started like (bt:make-thread (lambda () (run-frame-top-level *fr*))) and managed from the repl and/or buttons.")

(defclass blueprint
    ()
  ((walls :type t :initarg :walls)
   (pillars :type t :initarg :pillars)
   (scale :type rational :initarg :scale)
   (opposite-day :initform nil :accessor opposite-day))
  (:default-initargs :scale 1 :walls (list) :pillars (list)))

(defmethod make-load-form
    ((obj blueprint) &optional env)
  (declare (ignorable env))
  `(make-instance
    'blueprint
    :walls (copy-tree ',(slot-value obj 'walls))
    :pillars (copy-tree ',(slot-value obj 'pillars))
    :scale (copy-tree ',(slot-value obj 'scale))))

(define-application-frame
    blueprint-frame
    (blueprint standard-application-frame)
  ()
  (:pane :application
   :display-function 'draw-blueprint))

(defmethod make-load-form
    ((obj blueprint-frame) &optional env)
  (declare (ignorable env))
  (let ((form (call-next-method obj)))
    (setf (second form) 'blueprint-frame
	  (first form) 'make-application-frame)
    form))

(defmethod draw-blueprint
    ((obj blueprint-frame) stream)
  (with-slots
	(scale walls pillars)
      obj
    (flet ((draws (obj stream)
	     (with-scaling
	  (stream scale scale)
	(loop for wallses in walls when (cdr wallses) do
	  (medium-draw-polygon*
	   stream
	   (apply 'append (cdr wallses))
	   nil nil))
	(with-drawing-options
	    (stream :ink +black+)
	(loop for p in pillars for (x y r) = p do
	    (draw-oval*
	     stream x y r 0)
	      ))
	)))
      (if ((lambda () (not (opposite-day obj))))
	  (with-room-for-graphics
	      (stream)
	    (draws obj stream))
	  (draws obj stream))
      )))

(define-blueprint-frame-command
    (com-help :menu t)
    ()
  (format *terminal-io*
	  "~@{~?~^~%~}"
	  "Set the blueprint-frame:" ()
	  "(setq *fr* (make-application-frame 'blueprint-frame))" ()
	  "Start the frame in a background thread:" ()
	  "(bt:make-thread (lambda () (run-frame-top-level *fr*)))" ()
	  "Add a new wall segment:" ()
	  "(*pt -3 20)" ()
	  "Connect a point:" ()
	  "(+pt 10 -5)" ()
	  "Erase the last point:" ()
	  "(-pt)" ()
	  "Add a pillar:" ()
	  "(+pl 10 20 1.5)" ()
	  "Remove last pillar:" ()
	  "(-pl)" ()
	  "Clicking on the frame says the nearest point" ()
	  "But this only works when upsidedown." ()
	  "So push the opp-osite day button first." ()
	  "Save a frame:" ()
	  "(make-load-form *fr*)" ()
	  "Change scale:" ()
	  "(res 5.1)" ()))

(defmethod new-walls
    ((obj blueprint) x y)
  (with-slots
	(walls)
      obj
    (setq
     walls 
     (cons (list :wall (list x y)) walls))))

(define-blueprint-frame-command
    (com-new-walls)
    ((x integer)
     (y integer))
  (new-walls *application-frame* x y))

(defmethod conc-wall ((obj blueprint) x y)
  (with-slots
	(walls)
      obj
    (setf (first walls)
	  (nconc (first walls)
		 `((,x ,y))))))

(define-blueprint-frame-command
    (com-conc-wall)
    ((x integer)
     (y integer))
  (conc-wall *application-frame* x y))

(define-blueprint-frame-command
    (com-rescale)
    ((r integer))
  (with-slots
	(scale)
      *application-frame*
    (setq scale r)))

(defun res (x)
  (execute-frame-command *fr* `(com-rescale ,x)))

(defun +pt (x y)
  (execute-frame-command
   *fr*
   `(com-conc-wall ,x ,y)))

(defun *pt (x y)
  (execute-frame-command
   *fr*
   `(com-new-walls ,x ,y)))

(define-blueprint-frame-command
    (com-nbut-pt)
    ()
  (with-slots
	(walls)
      *application-frame*
    (setf (first walls)
	  (case (length (first walls))
	    (2 (setf (cdr (first walls)) nil)
	     (first walls))
	    (t (nbutlast (first walls)))))))

(defun -pt ()
  (execute-frame-command
   *fr*
   '(com-nbut-pt)))

(defmethod pillar ((obj blueprint)
		   x y r)
  (with-slots
	(pillars)
      obj
    ;;(medium-draw-ellipse* stream x y (- r) (- r) r r 0 360 nil)
    (setq pillars (cons (list x y r) pillars))))

(defun -pillar ()
  (with-slots
	(pillars)
      *fr*
    (setq pillars (cdr pillars))))

(define-blueprint-frame-command
    (com-+pillar)
    ((x integer) (y integer) (r integer))
  (pillar *application-frame* x y r))

(define-blueprint-frame-command
    (com--pillar)
    ()
  (-pillar))

(defun +pl (x y r)
  (execute-frame-command
   *fr*
   `(com-+pillar ,x ,y ,r)))

(defun -pl ()
  (execute-frame-command
   *fr*
   `(com--pillar)))

(define-presentation-action
    just-print-xy
    (clim:blank-area nil blueprint-frame)
    (presentation x y)
  (with-slots
	(pillars walls scale)
      *application-frame*
    (let ((found-x nil)
	  (found-y nil))
      (loop for w in walls when (cdr w) do
	(loop
	  for (xi yi) in (cdr w)
	  if (null found-x) do
	    (setf found-x xi
		  found-y yi)
	  else do
	    (let ((n (+ (expt (- (/ x scale)
				 xi)
			      2)
			(expt (- (/ y scale)
				 yi)
			      2)))
		  (o (+ (expt (- (/ x scale)
				 found-x)
			      2)
			(expt (- (/ y scale)
				 found-y)
			      2))))
	      (when (> o n)
		(setf found-x xi
		      found-y yi)))))
      (loop for (xi yi r) in pillars
	    if (null found-x)
	      do
		 (setf found-x xi found-y yi)
	    else do
	      (let ((n (+ (expt (- (/ x scale) xi) 2)
			(expt (- (/ y scale) yi) 2)))
		  (o (+ (expt (- (/ x scale) found-x) 2)
			(expt (- (/ y scale) found-y) 2))))
	      (when (> o n)
		(setf found-x xi
		      found-y yi))))
      
      (print (list found-x found-y) *terminal-io*))))

(define-blueprint-frame-command
    (com-opp :menu t)
    ()
  (setf (opposite-day *application-frame*)
	(not (opposite-day *application-frame*))))


(MAKE-INSTANCE 'BLUEPRINT
               :WALLS
               (COPY-TREE
                '((:WALL (14 10) (18 10) (20 10) (18 10) (18 20) (17 20))
                  (:WALL (14 20)) (:WALL (14 20) (4 20))
                  (:WALL (4 20) (4 -3) (14 -3) (14 20) (4 20) (15 20) (16 20))
                  (:WALL (-3 16) (-3 11) (4 11) (4 18) (4 20) (1 20))
                  (:WALL (-3 18) (-10 18) (-10 -5) (-3 -5) (-3 18))
                  (:WALL (-3 20) (-3 26) (-10 26) (-10 20) (-1 20))
                  (:WALL (-3 28) (-10 28) (-10 26) (-3 26) (-3 28))
                  (:WALL (-3 45) (-3 47) (-10 47) (-10 28) (-3 28) (-3 43))
                  (:WALL (13 22) (17 22) (15 22) (13 22) (13 25) (8 25) (8 22))
                  (:WALL (19 23) (19 43) (19 22) (19 43) (0 43) (0 22) (19 22))
                  (:WALL (25 16) (25 17) (20 17) (20 16) (25 16))
                  (:WALL (31 22) (31 24) (31 20) (31 24) (22 24) (22 -7)
                   (31 -7) (31 16) (39 16) (31 16) (31 18) (31 10) (46 10)
                   (46 16) (41 16))
                  (:WALL (22 24) (31 24) (31 28) (22 28) (22 27))
                  (:WALL (22 32) (22 28) (37 28) (37 38) (22 38) (22 34))
                  (:WALL (22 39) (22 38) (31 38) (31 41) (22 41) (22 40))
                  (:WALL (31 51) (46 51) (46 60) (31 60))
                  (:WALL (35 60) (35 70) (22 70) (22 64) (-10 64) (-10 47)
                   (22 47) (22 41) (35 41) (35 51))))
               :PILLARS
               (COPY-TREE
                '((46 10 1) (31 -7 1) (41 16 1) (46 16 1) (11 52 1) (7 52 1)
                  (3 52 1) (-1 52 1) (-5 59 1) (-5 52 1) (-1 59 1) (3 59 1)
                  (7 59 1) (11 59 1) (15 59 1) (15 52 1) (19 52 1) (19 59 1)
                  (23 52 1.5) (23 59 1.5) (30 66 1) (30 63 1) (30 59 1.5)
                  (30 45 1) (30 48 1) (30 52 1.5)))
               :SCALE
               (COPY-TREE '12))

(defvar *fr* (make-application-frame 'blueprint-frame))