#!/usr/bin/guile
!#

(import (sph) (sph pattern)
  (sxml simple) (sph conditional)
  (sph stream) (srfi srfi-41)
  (sph svg) (sph lang plcss)
  (term ansi-color) (sph list) (sph tree) (ice-9 match) (rnrs lists) (sph alist))

(define-as relative-direction-name vector "l" "r" "s")
(define-as position-name vector "w" "s" "e" "n")

(define (get-relative-position position distance)
  (let (n (+ position distance)) (if (> n 3) (modulo n 4) n)))

(define (color-by-priority a priority) "string integer -> string"
  (apply colorize-string a
    (case priority ((0) (ql GREEN BOLD)) ((1) (ql GREEN)) ((2) (ql RED)) ((3) (ql RED BOLD)))))

(define (get-relative-priorities position direction) "vector -> vector:priority-pattern"
  (and direction
    (if (= 0 direction)
      (list (get-relative-position position 2) (get-relative-position position 1))
      (list (get-relative-position position 1)))))

(define (get-priority-situation a)
  (let*
    ( (non-null-positions (list-indices identity a))
      (situation
        (filter identity
          (map-with-index
            (l (i e)
              (and e
                (pair i
                  (vector (length (intersection non-null-positions (get-relative-priorities i e)))
                    e))))
            a))))
    situation))

(define (display-situation a)
  (apply simple-format #t
    "  ~A\n~A   ~A\n  ~A\n_\n"
    (map
      (l (key)
        (pass-if (alist-ref a key)
          (l (e)
            (color-by-priority (vector-ref relative-direction-name (vector-ref e 1))
              (vector-ref e 0)))
          " "))
      (list 3 0 2 1))))

(define (get-situation-stream filter-proc)
  (stream-map get-priority-situation
    (stream-filter filter-proc (stream-map vector->list (permutation-stream #(0 1 2 #f) 4)))))

(define (default-situation-filter e)
  (and (list-ref e 1)
    (let (non-empty-length (length (delv #f e)))
      (not (or (= 4 non-empty-length) (= 1 non-empty-length) (= 0 non-empty-length))))))

(define-as arrows vector "" "←" "↑" "→" "↓")

(define (position+direction->arrow position direction)
  (vector-ref arrows
    (match (list position direction) ((0 0) 2)
      ((0 1) 4) ((0 2) 3)
      ((1 0) 1) ((1 1) 3) ((1 2) 2) ((2 0) 4) ((2 1) 2) ((2 2) 1) ((3 0) 3) ((3 1) 1) ((3 2) 4) (_ 0))))

(define car-width 17.5)
(define situation-width 140)
(define car-lane-spacing 5)
(define street-width (+ (* 2 car-lane-spacing) (* 2 car-width)))
(define lane-marking-width 3)
(define situation-middle (floor (/ situation-width 2)))
(define half-street-width (floor (/ street-width 2)))
(define street-color "#999")
(define line-markings-dash "10,7.5")
(define lane-marking-color "#eee")
(define entry-distance 30)
(define signal-width 4)
(define street-border-color "#888")

(define streets
  (qq
    (polygon
      (@ (style "fill:" (unquote street-color) ";stroke-width:1;stroke:" street-border-color)
        (points
          (unquote
            (svg-points (0 (- situation-middle half-street-width))
              ((- situation-middle half-street-width) (- situation-middle half-street-width))
              ((- situation-middle half-street-width) 0) ((+ situation-middle half-street-width) 0)
              ((+ situation-middle half-street-width) (- situation-middle half-street-width))
              (situation-width (- situation-middle half-street-width))
              (situation-width (+ situation-middle half-street-width))
              ((+ situation-middle half-street-width) (+ situation-middle half-street-width))
              ((+ situation-middle half-street-width) situation-width)
              ((- situation-middle half-street-width) situation-width)
              ((- situation-middle half-street-width) (+ situation-middle half-street-width))
              (0 (+ situation-middle half-street-width)))))))))

(define lane-marking
  (qq
    ( (line
        (@ (stroke-width (unquote lane-marking-width)) (stroke (unquote lane-marking-color))
          (stroke-dasharray (unquote line-markings-dash)) (x1 (unquote situation-middle))
          (y1 0) (x2 (unquote situation-middle))
          (y2 (unquote (- situation-middle half-street-width)))))
      (line
        (@ (stroke-width (unquote lane-marking-width)) (stroke (unquote lane-marking-color))
          (stroke-dasharray (unquote line-markings-dash)) (x1 (unquote situation-middle))
          (x2 (unquote situation-middle)) (y1 (unquote (+ situation-middle half-street-width)))
          (y2 (unquote situation-width))))
      (line
        (@ (stroke-width (unquote lane-marking-width)) (stroke (unquote lane-marking-color))
          (stroke-dasharray (unquote line-markings-dash)) (x1 0)
          (x2 (unquote (- situation-middle half-street-width))) (y1 (unquote situation-middle))
          (y2 (unquote situation-middle))))
      (line
        (@ (stroke-width (unquote lane-marking-width)) (stroke (unquote lane-marking-color))
          (stroke-dasharray (unquote line-markings-dash))
          (x1 (unquote (+ situation-middle half-street-width))) (x2 (unquote situation-width))
          (y1 (unquote situation-middle)) (y2 (unquote situation-middle)))))))

(define (position->points a entry-distance)
  (cond ((= 0 a) (pair entry-distance situation-middle))
    ( (= 1 a)
      (pair (+ situation-middle car-lane-spacing) (- situation-width car-width entry-distance)))
    ( (= 2 a)
      (pair (- situation-width car-width entry-distance)
        (- situation-middle car-lane-spacing car-width)))
    ((= 3 a) (pair (- situation-middle car-width car-lane-spacing) entry-distance))))

(define (position->signal-points car-x car-y a right?)
  (cond
    ( (= 0 a)
      (if right? (pair (+ car-x (- car-width signal-width)) (+ (- car-width signal-width) car-y))
        (pair (+ car-x (- car-width signal-width)) car-y)))
    ((= 1 a) (if right? (pair (+ (- car-width signal-width) car-x) car-y) (pair car-x car-y)))
    ((= 2 a) (if right? (pair car-x car-y) (pair car-x (+ (- car-width signal-width) car-y))))
    ( (= 3 a)
      (if right? (pair car-x (+ (- car-width signal-width) car-y))
        (pair (+ (- car-width signal-width) car-x) (+ (- car-width signal-width) car-y))))))

(define (turn-signal car-x car-y position right?)
  (let (points (position->signal-points car-x car-y position right?))
    (qq
      (rect
        (@ (style "fill:orange") (x (unquote (first points)))
          (y (unquote (tail points))) (width (unquote signal-width)) (height (unquote signal-width)))))))

(define (car position direction)
  (let (points (position->points position entry-distance))
    (qq
      ( (rect
          (@ (x (unquote (first points))) (y (unquote (tail points)))
            (width (unquote car-width)) (height (unquote car-width))
            (style "fill:#fff;stroke:#000;stroke-width:1") (rx 3)))
        (unquote
          (if (= 2 direction) ""
            (turn-signal (first points) (tail points) position (= 1 direction))))))))

(define (situation->cars a)
  (map
    (l (e)
      (let
        ( (position (first e)) (priority (vector-ref (tail e) 0))
          (direction (vector-ref (tail e) 1)))
        (car position direction)))
    a))

(define (situation->svg a)
  (qq
    (svg
      (@ (class "situation")
        ;(shape-rendering crispEdges)
        (width (unquote situation-width)) (height (unquote situation-width))
        (xmlns "http://www.w3.org/2000/svg") (xmlns:xlink "http://www.w3.org/1999/xlink"))
      (unquote streets) (unquote lane-marking) (unquote (situation->cars a)))))

(let (s (get-situation-stream default-situation-filter))
  (display "<!DOCTYPE html><html><head><style>")
  (display (css ("*" "box-sizing" "border-box") (".situation" float "left" margin "15px")))
  (display "</style></head><body>") (sxml->xml (stream->list (stream-map situation->svg s)))
  (display "</body></html>"))