(require "clim")
(in-package :clim-user)


;;; The algorithm.

;; All points in (x y) coordinates.
(defconstant *points*
  '((9 53)  ; p0
    (99 53)  ; p1
    (54 43)  ; p2
    (35 39)  ; p3
    (72 39)  ; p4
    (25 37)  ; p5
    (82 37)  ; p6
    (54 30)  ; p7
    (40 22)  ; p8
    (68 22)  ; p9
    (54 8)))  ; p10

;; All segments.
;; A segment is a list of points, which are on the same line.
(defconstant *segments*
  '((0 5 8 10)
    (0 3 7 9)
    (0 2 4 6)
    (0 1)
    (1 2 3 5)
    (1 4 7 8)
    (1 6 9 10)))

;; Returns all possible sub-lines of a segment.
;; For example, if the points 1 2 and 3 are on the segment,
;; then the possible sub-lines are (1 2) (1 3) and (2 3).
(defun all-combinations (segment)
  (if (<= (length segment) 2)
      (sort (list segment) #'<)
    (append (map 'list
                 #'(lambda (x) (sort (list x (car segment)) #'<))
                 (cdr segment))
            (all-combinations (cdr segment)))))

;; Returns all possible lines of all segments.
(defun all-lines (segments)
  (if (null segments)
      nil
    (append (all-combinations (car segments)) (all-lines (cdr segments)))))

;; Returns t, if the two lines has at least one common point.
(defun shares-points (line1 line2)
  (destructuring-bind ((p1a p1b) (p2a p2b)) (list line1 line2)
    (or (= p1a p2a) (= p1a p2b) (= p1b p2a) (= p1b p2b))))

;; Returns t, if three of the points are on the same segment.
(defun all-in-segments (points)
  (dolist (segment *segments*)
    (let ((count 0))
      (dolist (p1 points)
        (dolist (p2 segment)
          (when (= p1 p2) (incf count))))
      (when (= count 3) (return-from all-in-segments t))))
  nil)

;; Returns t, if the two lines are equal.
(defun line-equal (line1 line2)
  (destructuring-bind ((p1a p1b) (p2a p2b)) (list line1 line2)
    (or (and (= p1a p2a) (= p1b p2b)) (and (= p1a p2b) (= p1b p2a)))))

;; Returns a triangle (a list of 3 points), if the three lines builds
;; a triangle and if each line is member of the lines list.
(defun make-triangle (l1 l2 l3 lines)
  (let* ((points (copy-seq (remove-duplicates `(,@l1 ,@l2 ,@l3))))
         (p1 (car points))
         (p2 (cadr points))
         (p3 (caddr points)))
    (if (and 
         (= (length points) 3) 
         (not (all-in-segments points))
         (shares-points l1 l2)
         (shares-points l2 l3)
         (shares-points l1 l3)
         (member (list p1 p2) lines :test #'line-equal)
         (member (list p2 p3) lines :test #'line-equal)
         (member (list p1 p3) lines :test #'line-equal))
        (sort points #'<)
      nil)))

;; Returns all possible triangles.
;; This is a nested loop: The first loop iterates through all lines,
;; which are compared to all rest lines. If both lines share at least
;; one point, it could be a valid triangle and the rest lines are checked
;; in the third loop.
(defun all-tris (lines)
  (let ((result nil))
    (when (>= (length lines) 3)
      (maplist
       #'(lambda (rest)
           (let ((l1 (car rest)))
             (maplist
              #'(lambda (rest)
                  (let ((l2 (car rest)))
                    (when (shares-points l1 l2)
                      (maplist
                       #'(lambda (rest)
                           (let* ((l3 (car rest))
                                  (tri (make-triangle l1 l2 l3 lines)))
                             (when (and tri 
                                        (not (member tri
                                                     result
                                                     :test #'equal)))
                               (push tri result))))
                       (cdr rest)))))
              (cdr lines))))
       lines))
    result))


;;; The GUI.

;; Defines the application frame.
(define-application-frame triangles-frame ()
  ()
  (:panes
   (display :application
            :display-function 'draw-triangles))
  (:layouts
   (default display))
  (:geometry :width 800 :height 500))

;; Shows the application frame.
(defun show-tris ()
  (let ((frame (make-application-frame 'triangles-frame)))
    (run-frame-top-level frame)))

;; Gets the scaled x-coordinate of the point.
(defun get-x (point count)
  (let* ((p (elt *points* point))
         (ofs-x (* 100 (mod count 7)))
         (x (+ (car p) ofs-x)))
    (float x)))

;; Gets the scaled y-coordinate of the point.
(defun get-y (point count)
  (let* ((p (elt *points* point))
         (ofs-y (* 100 (floor count 7)))
         (y (+ (cadr p) ofs-y)))
    (float y)))

;; Draws a scaled line.
(defun draw-my-line (stream p1 p2 count)
  (let* ((x1 (get-x p1 count))
         (y1 (get-y p1 count))
         (x2 (get-x p2 count))
         (y2 (get-y p2 count)))
    (draw-line* stream x1 y1 x2 y2)))

;; Draws a scaled polygon.
(defun draw-tri-polygon (stream p1 p2 p3 count)
  (let* ((x1 (get-x p1 count))
         (y1 (get-y p1 count))
         (x2 (get-x p2 count))
         (y2 (get-y p2 count))
         (x3 (get-x p3 count))
         (y3 (get-y p3 count)))
    (draw-polygon* stream (list x1 y1 x2 y2 x3 y3))))

;; The display function, which draws all triangles.
(defmethod draw-triangles ((frame triangles-frame) stream &key max-width max-height)
  (declare (ignore max-width max-height))
  (let* ((lines (all-lines *segments*))
         (tris (all-tris lines))
         (count 0))
    (dolist (tri tris)
      (dolist (segment *segments*)
        (let ((p1 (car segment))
              (p2 (car (last segment))))
          (draw-my-line stream p1 p2 count)))
      (destructuring-bind (p1 p2 p3) tri
        (draw-tri-polygon stream p1 p2 p3 count))
      (incf count))))

;; call it with (clim-user::show-tris)