dungeon-master/geom/triangle.scm

   1 ;;; Dungeon Master --- RPG Adventure Generator
   2 ;;; Copyright © 2019 Javier Sancho <jsf@jsancho.org>
   3 ;;;
   4 ;;; Dungeon Master is free software; you can redistribute it and/or modify it
   5 ;;; under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 3 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; Dungeon Master is distributed in the hope that it will be useful, but
  10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;; General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License
  15 ;;; along with Dungeon Master. If not, see <http://www.gnu.org/licenses/>.
  16
  17
  18 (define-module (dungeon-master geom triangle)
  19   #:use-module (ice-9 receive)
  20   #:use-module (srfi srfi-9)
  21   #:use-module (dungeon-master geom point)
  22   #:export (make-triangle
  23             triangle?
  24             triangle-points
  25             triangle-center
  26             triangle-radius
  27             triangle-has-edge))
  28
  29 (define-record-type <triangle>
  30   (make-raw-triangle points center radius)
  31   triangle?
  32   (points triangle-points)
  33   (center triangle-center)
  34   (radius triangle-radius))
  35
  36 (define (make-triangle p1 p2 p3)
  37   (let ((center (circumcenter p1 p2 p3)))
  38     (make-raw-triangle
  39      (list p1 p2 p3)
  40      center
  41      (points-distance center p1))))
  42
  43 (define (circumcenter p1 p2 p3)
  44   (receive (a b c)
  45       (perpendicular-line-from-points p1 p2)
  46     (receive (e f g)
  47         (perpendicular-line-from-points p2 p3)
  48       (let ((determinant (- (* a f) (* e b))))
  49         (make-point
  50          (/ (- (* f c) (* b g)) determinant)
  51          (/ (- (* a g) (* e c)) determinant))))))
  52
  53 (define (perpendicular-line-from-points p1 p2)
  54   (let ((x1 (point-x p1))
  55         (y1 (point-y p1))
  56         (x2 (point-x p2))
  57         (y2 (point-y p2)))
  58     (let* ((a (- y2 y1))
  59            (b (- x1 x2))
  60            (c (+ (* a x1) (* b y2))))
  61       (let ((mid-x (/ (+ x1 x2) 2))
  62             (mid-y (/ (+ y1 y2) 2)))
  63         (values (- b)
  64                 a
  65                 (+ (* (- b) mid-x) (* a mid-y)))))))
  66
  67 (define (triangle-has-edge triangle a b)
  68   (let ((points (triangle-points triangle)))
  69     (let ((p1 (car points))
  70           (p2 (cadr points))
  71           (p3 (caddr points)))
  72       (or (and (equal? p1 a) (equal? p2 b))
  73           (and (equal? p1 b) (equal? p2 a))
  74           (and (equal? p2 a) (equal? p3 b))
  75           (and (equal? p2 b) (equal? p3 a))
  76           (and (equal? p3 a) (equal? p1 b))
  77           (and (equal? p3 b) (equal? p1 a))))))