ocm/nvg.lisp

(cl:defpackage :ocm.nvg
  (:use :cl :cffi-c-ref :alexandria)
  (:export run))
(cl:in-package :ocm.nvg)

(defun aget (alist key)
  (cdr (assoc key alist :test #'equal)))

(defun agets (alist &rest keys)
  (reduce #'aget keys :initial-value alist))

(defun agetter (&rest keys)
  (lambda (alist)
    (apply 'agets alist keys)))

(defun tags (obj)
  (let ((tags (ocm.osm::obj-tags obj)))
    (when (functionp tags)
      (setf tags (funcall tags)
            (ocm.osm::obj-tags obj) tags))
    tags))

(defun merge-tags (obj parent)
  (append obj parent))


(defvar *context* nil "NanoVG Context")
(defvar *window-width* 640.0)
(defvar *window-height* 480.0)
(defvar *frame-width* 640.0)
(defvar *frame-height* 480.0)
(defvar *pixel-ratio* 1.0)
(defvar *scale* 3f0)
(defvar *pos-x* 0f0)
(defvar *pos-y* 0f0)

(defparameter +granularity+ (expt 10 8))
(defun node-x (node)
  (float (/ (ocm.osm::node-lat node) +granularity+)))
(defun node-y (node)
  (float (/ (ocm.osm::node-lon node) +granularity+)))

(defun render-path (nodes)
  (%nvg:begin-path *context*)
  (let ((start (car nodes)))
    (%nvg:move-to *context* (node-x start) (node-y start))
    (loop for node in (cdr nodes)
       do (%nvg:line-to *context* (node-x node) (node-y node)))))

(defparameter +highway-color+ '(250 0 0 255))
(defparameter +strokes+
  `(
    (((:way "highway")) :color ,+highway-color+ :width 10)))

(defun apply-stroke (tags)
  (when-let (options (find-match +strokes+ tags :way))
    (destructuring-bind (&key color width) options
      (when color
        (c-with ((n-color %nvg:color))
          (%nvg:stroke-color *context* (apply '%nvg:rgba (n-color &) color))))
      (when width (%nvg:stroke-width *context* width)))))


(defun render-line (nodes tags)
  (render-path nodes)
  (apply-stroke tags)
  (%nvg:stroke *context*))

(defparameter +water-color+ '(0 0 250 255))
(defparameter +wood-color+ '(0 250 0 255))
(defparameter +fills+
  `(
    (((nil "natural" "water")) :color ,+water-color+)
    (((nil "natural" "scrub")
      (nil "natural" "wood")) :color ,+wood-color+)
    ))

(defun find-match (query-value tags type)
  (loop for (query . value) in query-value
     when (ocm.osm::query-match2 query type tags)
     do (return value)))

(defun apply-fill (tags)
  (when-let (fill (find-match +fills+ tags :way))
    (destructuring-bind (&key color paint) fill
      (when color
        (c-with ((n-color %nvg:color))
          (%nvg:fill-color *context* (apply '%nvg:rgba (n-color &) color))))
      (when paint))))


(defun render-poly (nodes tags &optional hole)
  (render-path nodes)
  (%nvg:close-path *context*)
  (when hole
    (%nvg:path-winding *context* (cffi:foreign-bitfield-value '%nvg:solidity :hole)))
  (apply-fill tags)
  (%nvg:fill *context*))

(defparameter +closed-lines+
  '((:way "highway")))

(defun is-area (nodes tags)
  (let ((first (first nodes))
        (last (car (last nodes))))
    (and first last
         (= (if (ocm.osm::obj-p first) (ocm.osm::obj-id first) first)
            (if (ocm.osm::obj-p last) (ocm.osm::obj-id last) last))
         (not (ocm.osm::query-match2 +closed-lines+ :way tags)))))

(defun render-way (nodes tags)
  (if (is-area nodes tags)
      (render-poly nodes tags)
      (render-path nodes)))

(defun render-multipoly (rel)
  (loop for mem in (ocm.osm::rel-memids rel)
     for mem-role in (ocm.osm::rel-roles rel)
     for mem-type in (ocm.osm::rel-types rel)
     when (ocm.osm::way-p mem) ;; skip non-ways
     do (render-poly (ocm.osm::way-refs mem)
                     (merge-tags (tags mem) (tags rel))
                     (equal "inner" mem-role))))

(defun render-objects (objects)
  (loop for obj in objects
     do (typecase obj
          (ocm.osm::way
           (render-way (ocm.osm::way-refs obj) (tags obj)))
          (ocm.osm::rel
           (when (equal (aget (tags obj) "type")
                        "multipolygon")
             (render-multipoly obj))))))

(defun render ()
  (%nvg:begin-frame *context* *window-width* *window-height* *pixel-ratio*)

  (%nvg:transform *context* *scale* 0f0 0f0 *scale* *pos-x* *pos-y*)

  (render-objects ocm.osm::+water+)

  (%nvg:begin-path *context*)
  (%nvg:rect *context* 0f0 0f0 120f0 30f0)
  (c-with ((color %nvg:color))
    (%nvg:fill-color *context* (%nvg:rgba (color &)
                                          (round (* 127.5 (+ 1 (sin (* 2 (%glfw:get-time))))))
                                          192 192 255)))
  (%nvg:fill *context*)

  (%nvg:end-frame *context*)
  )

(defparameter +translate-step+ 10f0)
(defparameter +scale-step+ 0.1)
(glfw:define-key-callback on-keys (window key scancode action mod-keys)
  (declare (ignorable window key scancode action mod-keys))
  (format t "KEY: ~{~A ~}~%" (list key scancode action mod-keys))
  (when (eql action %glfw:+press+)
    (cond
      ((or
        (eql key %glfw:+key-escape+)
        (eql key %glfw:+key-q+))
       (%glfw:set-window-should-close window %glfw:+true+))
      ((eql key %glfw:+key-left+) (decf *pos-x* +translate-step+))
      ((eql key %glfw:+key-right+) (incf *pos-x* +translate-step+))
      ((eql key %glfw:+key-up+) (decf *pos-y* +translate-step+))
      ((eql key %glfw:+key-down+) (incf *pos-y* +translate-step+))
      ((eql key %glfw:+key-minus+) (decf *scale* +scale-step+))
      ((eql key %glfw:+key-equal+) (incf *scale* +scale-step+))))
  (print (list *scale* *pos-x* *pos-y*)))

(glfw:define-framebuffer-size-callback on-fb-size (window width height)
  (declare (ignorable window))
  (setf *frame-width* (float width)
        *frame-height* (float height)
        *pixel-ratio* (/ *frame-width* *window-width*)))

(glfw:define-window-size-callback on-win-size (window width height)
  (declare (ignorable window))
  (setf *window-width* (float width)
        *window-height* (float height)
        *pixel-ratio* (/ *frame-width* *window-width*)))

(Defun create-window ()
  (if (uiop:featurep :bodge-gl2)
      (glfw:with-window-hints ((%glfw:+context-version-major+ 2)
                               (%glfw:+context-version-minor+ 1)
                               (%glfw:+depth-bits+ 24)
                               (%glfw:+stencil-bits+ 8))
        (%glfw:create-window 640 480 "Hello NanoVG 2" nil nil))
      (glfw:with-window-hints ((%glfw:+context-version-major+ 3)
                               (%glfw:+context-version-minor+ 3)
                               (%glfw:+opengl-profile+ %glfw:+opengl-core-profile+)
                               (%glfw:+opengl-forward-compat+ %glfw:+true+)
                               (%glfw:+depth-bits+ 24)
                               (%glfw:+stencil-bits+ 8))
        (%glfw:create-window 640 480 "Hello NanoVG 3" nil nil))))

(defun main ()
  ;; Initializing window and OpenGL context
  (glfw:with-init ()
    (c-let ((window %glfw:window :from (create-window))
            (width :int :alloc t)
            (height :int :alloc t))
      (when (cffi:null-pointer-p (window &))
        (%glfw:terminate)
        (error "Failed to create GLFW window"))
      (%glfw:make-context-current (window &))
      ;; Mangling GL function pointers
      (glad:init)
      ;; Set event callbacks
      (%glfw:set-key-callback (window &) (cffi:callback on-keys))
      (%glfw:set-framebuffer-size-callback (window &) (cffi:callback on-fb-size))
      (%glfw:set-window-size-callback (window &) (cffi:callback on-win-size))
      ;; Get initial values
      (%glfw:get-framebuffer-size (window &) (width &) (height &))
      (setf *frame-width* (float width)
            *frame-height* (float height))
      (%glfw:get-window-size (window &) (width &) (height &))
      (setf *window-width* (float width)
            *window-height* (float height)
            *pixel-ratio* (/ *frame-width* *window-width*))

      ;; reset
      (setf *scale* 1f0
            *pos-x* 0f0
            *pos-y* 0f0)

      ;; Creating NanoVG context
      (let ((*context* (nvg:make-context)))
        (unwind-protect
             (loop while (= (%glfw:window-should-close (window &)) 0) do
                  (gl:clear-color 1f0 1f0 1f0 1f0)
                  (gl:clear :color-buffer-bit :depth-buffer-bit :stencil-buffer-bit)

                ;; Actually drawing into nanovg context and onto display
                  (render)

                  (%glfw:swap-buffers (window &))
                  (%glfw:poll-events))
          ;; Cleaning up NanoVG context
          (nvg:destroy-context *context*))))))

(defun run ()
  (main)
  ;; (trivial-main-thread:with-body-in-main-thread (:blocking t)
  ;;   (float-features:with-float-traps-masked t
  ;;     (main)))
  )