ywatds/webui/conns.scm

(use-modules (aux v2d) (aux math))

(define (conns-query->qstring qlist)
  (let ((f (lambda (elem) (format #f "~d=~d" (car elem) (cdr elem)))))
    (format #f "~{~a~^&~}" (map-in-order f qlist))))

(define (conns-handler-get-query qlist)
  (let* ((valid-conns-string?
	  (lambda (str)
	    (and (string-every char-numeric? str)
		 (let ((snum (string->number str)))
		   (and (integer? snum) (< snum 16) (>= snum 0))))))
	 (query-filter
	  (lambda (elem)
	    (and (pair? elem)
		 (valid-conns-string? (car elem))
		 (valid-conns-string? (cdr elem)))))
	 (seen? (make-vector 256 #f))
	 (query-iter
	  (lambda (elem)
	    (and (query-filter elem)
		 (let* ((from (string->number (car elem)))
			(to (string->number (cdr elem)))
			(idx (+ (* 16 from) to)))
		   (and (not (vector-ref seen? idx))
			(begin
			  (vector-set! seen? idx #t)
			  (cons from to))))))))
    (delq! #f (map query-iter qlist))))

(define half-curve-memoization (make-vector 256 #f))

(define (clist->svg query)
  (let* ((svg-size 512)
	 (adjust (lambda (x n) (modulo (+ x n) 16)))
	 (dir->pos-map
	  ;; note that this vector maps north to -y
	  #((0 . -1) (1/2 . -1) (1 . -1) (1 . -1/2)
	    (1 . 0) (1 . 1/2) (1 . 1) (1/2 . 1)
	    (0 . 1) (-1/2 . 1) (-1 . 1) (-1 . 1/2)
	    (-1 . 0) (-1 . -1/2) (-1 . -1) (-1/2 . -1)))
	 (dir->pos (lambda (dir size)
		     (let ((pos-entry (vector-ref dir->pos-map dir)))
		       (v2d* (v2d+ pos-entry 1) size 1/2))))
	 (offset-pos (lambda (pos dir length)
		       (let ((ent (vector-ref dir->pos-map dir)))
			 (v2d+ (v2d-extend-to-length ent length) pos))))
	 (half-curve
	  (lambda (from to size width)
	    (let* ((idx (+ (* 16 from) to))
		   (memoization (vector-ref half-curve-memoization idx)))
	      (if memoization memoization
		  (let*
		      ((aux (lambda (dir off)
			      (v2d-floor (offset-pos (dir->pos dir size)
						     (adjust dir off)
						     (/ width 2)))))
		       (p1 (aux from 4))
		       (p2 (aux to 12))
		       (p0 (v2d-floor (v2d+ (v2d*
					     (vector-ref dir->pos-map from)
					     width)
					    p1)))
		       (p3 (v2d-floor (v2d+ (v2d*
					     (vector-ref dir->pos-map to)
					     width)
					    p2)))
		       (d1 (v2d- (vector-ref dir->pos-map from)))
		       (d2 (v2d- (vector-ref dir->pos-map to)))
		       (c (v2d-intersection p1 p2 d1 d2))
		       (s (if c
			      (format
			       #f "~d~@dL~d~@dQ~d~@d~@d~@dL~d~@d"
			       (car p0) (cdr p0) (car p1) (cdr p1)
			       (floor-exact (car c))
			       (floor-exact (cdr c))
			       (car p2) (cdr p2) (car p3) (cdr p3))
			      (format
			       #f "~d~@dL~d~@dL~d~@dL~d~@d"
			       (car p0) (cdr p0) (car p1) (cdr p1)
			       (car p2) (cdr p2) (car p3) (cdr p3)))))
		    (vector-set! half-curve-memoization idx s)
		    s)))))
	 (make-path-entry
	  (lambda (elem)
	    (let* ((size svg-size)
		   (width (/ size 4))
		   (from (car elem))
		   (to (cdr elem))
		   (c1 (half-curve from to size width))
		   (c2 (half-curve to from size width)))
	      (if (and c1 c2)
		  (format #f "M~aL~aZ" c1 c2)
		  ""))))
	 (path-string (string-concatenate (map make-path-entry query))))
    `(,svg-size
      ,svg-size
      (path (@ (d ,path-string)
	       (stroke "#000")
	       (stroke-width ,(floor-exact (/ svg-size 32)))
	       (fill "#be2d2c"))))))

(define (conns-handler-draw-svg original-query)
  (let ((query (conns-handler-get-query original-query)))
    (respond-svg (clist->svg query))))

(define (conns-handler-draw-preview-page original-query)
  (let* ((dirnames
	  #("N" "NNE" "NE" "ENE" "E" "ESE" "SE" "SSE"
	    "S" "SSW" "SW" "WSW" "W" "WNW" "NW" "NNW"))
	 (query (conns-handler-get-query original-query))
	 (li-aux
	  (lambda (setter pair value)
	    (let ((cw (modulo (+ value 1) 16))
		  (ccw (modulo (+ value 15) 16)))
	      `((td (a (@ (href "/conns-preview?"
				,(begin (setter pair ccw)
					(conns-query->qstring query))))
		       "\u21b6"))
		(td ,(format #f "~a" (vector-ref dirnames value)))
		(td (a (@ (href "/conns-preview?"
				,(begin (setter pair cw)
					(conns-query->qstring query))))
		       "\u21b7"))
		,(begin (setter pair value) "")))))
	 (colsep `(td (@ (style "margin:0;padding:0"))))
	 (rowsep `(tr (td (@ (style "margin:0;padding:0")
			     (colspan 9)))))
	 (li (lambda (elem)
	       `(tr
		 (td (a (@ (href "/conns-preview?"
				 ,(conns-query->qstring
				   (delete elem query))))
			"Delete"))
		 ,colsep
		 ,@(li-aux set-car! elem (car elem))
		 ,colsep
		 ,@(li-aux set-cdr! elem (cdr elem))))))
    (respond-html
     `("Conns preview"
       (table (@ (class "standard-table align-center thick-table-borders")
		 (style "width:min-content"))
	      (tr (th "Action")
		  ,colsep
		  (th (@ (colspan 3)) "From")
		  ,colsep
		  (th (@ (colspan 3)) "To"))
	      ,@(map-in-order li query)
	      (tr (td (a (@ (href "/conns-preview?"
				  ,(conns-query->qstring
				    (append query '((0 . 8))))))
			 "(Add)"))
		  ,colsep
		  (td (@ (class "unavailable") (colspan 3)) "N")
		  ,colsep
		  (td (@ (class "unavailable") (colspan 3)) "S"))
	      ,rowsep
	      (tr (th (@ (colspan 9)) "Preview"))
	      (tr (td (@ (colspan 9)
			 (style "margin:0;padding:0"))
		      (img (@ (src "/conns.svg?"
				   ,(conns-query->qstring query))
			      (style "width:100%;height:auto;")))))
	      ,rowsep
	      (tr (th (@ (colspan 9)) "Notes"))
	      (tr (td (@ (colspan 9)
			 (style "text-align:initial"))
		      "Duplicate entries are only shown once.")))))))

(set! dataserver-handlers
      (cons* (cons '("conns.svg") conns-handler-draw-svg)
	     (cons '("conns-preview") conns-handler-draw-preview-page)
	     dataserver-handlers))