guile-algorithm-examples/basics/geometry.scm

(library (geometry (0 0 1))
  (export point
          make-point
          get-point-label
          get-point-coords
          get-point-coord

          vector->point

          make-element-wise-vector-operation
          vec+vec
          vec*vec
          make-arbitrary-arity-vector-operation

          vector+
          vector*
          vector-dot-product
          vector-scalar-product
          vec*sca
          vector-cross-product
          vector-magnitude
          vectors-perpendicular?
          vectors-angle-between

          counter-clockwise?
          clockwise?
          colinear?
          counter-clockwise-function
          ccw)
  (import
    (except (rnrs base)
            error
            vector-map)
    (only (guile) lambda* λ error)
    ;; structs
    (srfi srfi-9)
    (srfi srfi-9 gnu)
    ;; fold and list operations
    (srfi srfi-1)
    ;; vector operations
    (srfi srfi-43)))


(define-immutable-record-type <point>
  ;; define constructor
  (point label coords)
  ;; define predicate
  point?
  ;; define accessors and functional setters
  (label get-point-label set-point-label)
  (coords get-point-coords set-point-coords))


(define make-point
  (lambda* (coords #:key (label #f))
    (cond
     [(vector? coords)
      (cond
       [label (point label coords)]
       [else (point 'unlabeled coords)])]

     [(list? coords)
      (cond
       [label (point label (list->vector coords))]
       [else (point 'unlabeled (list->vector coords))])]

     [else
      (error "coordinates are supposed to be given as a list or vector")])))


(define get-point-coord
  (λ (a-point coord-ind)
    (vector-ref (get-point-coords a-point) coord-ind)))


(define vector->point
  (lambda* (vec #:key (label #f))
    (cond
     [label
      (point label vec)]
     [else
      (point 'unlabeled vec)])))


(define make-element-wise-vector-operation
  (lambda (elem-wise-op)
    ;; Return a vector operation, which works element-wise
    ;; with 2 vectors to create a new vector.
    (lambda (v1 v2)
      (let ([len1 (vector-length v1)]
            [len2 (vector-length v2)])
        (cond
         [(= len1 len2)
          (let ([res-vec (make-vector len1)])
            (let iter ([ind 0])
              (cond
               [(< ind len1)
                ;; Update the vector in-place.
                (vector-set! res-vec
                             ind
                             ;; Make use of the element-wise
                             ;; operation.
                             (elem-wise-op (vector-ref v1 ind)
                                           (vector-ref v2 ind)))
                (iter (+ ind 1))]
               [else
                res-vec])))]
         [else
          (error "vectors do not have same length")])))))


(define vec+vec
  (make-element-wise-vector-operation +))


(define vec*vec
  (make-element-wise-vector-operation *))


(define make-arbitrary-arity-vector-operation
  (lambda (elem-wise-vec-op op-neutral-elem)
    ;; Return a procedure, which takes an arbitrary number
    ;; of arguments and works through them using the given
    ;; element-wise vector operation.
    (lambda (vec1 vec2 . rest-vecs)
      (fold elem-wise-vec-op
            (make-vector (vector-length vec1) op-neutral-elem)
            (cons vec1
                  (cons vec2
                        rest-vecs))))))


(define vector+
  (make-arbitrary-arity-vector-operation vec+vec 0))


(define vector*
  (make-arbitrary-arity-vector-operation vec*vec 1))


(define vector-dot-product
  (lambda (v1 v2)
    (vector-fold (lambda (ind acc elem1 elem2)
                   (+ acc (* elem1 elem2)))
                 0
                 v1 v2)))
;; alias
(define vector-scalar-product
  vector-dot-product)


(define vec*sca
  (lambda (vec sca)
    (vector-map (λ (ind elem) (* elem sca))
                vec)))


(define vector-cross-product
  (lambda (v1 v2)
    (let ([len1 (vector-length v1)]
          [len2 (vector-length v2)])
      (cond
       ;; The cross product is only defined for 3
       ;; dimensions.
       [(= len1 len2 3)
        (let ([a1 (vector-ref v1 0)]
              [a2 (vector-ref v1 1)]
              [a3 (vector-ref v1 2)]
              [b1 (vector-ref v2 0)]
              [b2 (vector-ref v2 1)]
              [b3 (vector-ref v2 2)])
          (vector (- (* a2 b3) (* a3 b2))
                  (- (* a3 b1) (* a1 b3))
                  (- (* a1 b2) (* a2 b1))))]
       [else
        (error "one of the vectors does not have correct dimensions for cross product")]))))


(define vector-magnitude
  (λ (vec)
    (sqrt
     (vector-fold
      (λ (ind acc elem)
        (+ acc (* elem elem)))
      0
      vec))))


(define vectors-perpendicular?
  (λ (v1 v2)
    (= (vector-dot-product v1 v2) 0)))


(define vectors-angle-between
  (λ (v1 v2)
    (/ (vector-dot-product v1 v2)
       (* (vector-magnitude v1)
          (vector-magnitude v2)))))


(define counter-clockwise?
  (λ (a b c)
    (let ([dx1 (- (get-point-coord b 0)
                  (get-point-coord a 0))]
          [dx2 (- (get-point-coord c 0)
                  (get-point-coord a 0))]
          [dy1 (- (get-point-coord b 1)
                  (get-point-coord a 1))]
          [dy2 (- (get-point-coord c 1)
                  (get-point-coord a 1))])
      (cond
       [(> (* dx1 dy2) (* dy1 dx2)) #t]
       [else #f]))))


(define clockwise?
  (λ (a b c)
    (let ([dx1 (- (get-point-coord b 0)
                  (get-point-coord a 0))]
          [dx2 (- (get-point-coord c 0)
                  (get-point-coord a 0))]
          [dy1 (- (get-point-coord b 1)
                  (get-point-coord a 1))]
          [dy2 (- (get-point-coord c 1)
                  (get-point-coord a 1))])
      (cond
       [(< (* dx1 dy2) (* dy1 dx2)) #t]
       [else #f]))))


(define colinear?
  (λ (a b c)
    (let ([dx1 (- (get-point-coord b 0)
                  (get-point-coord a 0))]
          [dx2 (- (get-point-coord c 0)
                  (get-point-coord a 0))]
          [dy1 (- (get-point-coord b 1)
                  (get-point-coord a 1))]
          [dy2 (- (get-point-coord c 1)
                  (get-point-coord a 1))])
      (cond
       [(= (* dx1 dy2) (* dy1 dx2)) #t]
       [else #f]))))


(define counter-clockwise-function
  (λ (a b c)
    "Return a positive number, if the angle of ab to bc is counter clockwise, a
negative number, if the angle is clockwise and 0 if the points are colinear (on
the same line)."
    (let ([dx1 (- (get-point-coord b 0)
                  (get-point-coord a 0))]
          [dx2 (- (get-point-coord c 0)
                  (get-point-coord a 0))]
          [dy1 (- (get-point-coord b 1)
                  (get-point-coord a 1))]
          [dy2 (- (get-point-coord c 1)
                  (get-point-coord a 1))])
      (cond
       [(> (* dx1 dy2) (* dy1 dx2)) 1]
       [(< (* dx1 dy2) (* dy1 dx2)) -1]
       [else 0]))))


(define ccw counter-clockwise-function)