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