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)

(defvar *objects* nil "List of OSM referenced objects to render")



(defun fix-multipoly (rel)
  (labels ((id (obj) (ocm.osm::obj-id obj))
           (try-attach (way ways)
             (loop
                with way-nodes = (ocm.osm::way-refs way)
                with way-first = (car way-nodes)
                with way-last = (car (last way-nodes))
                for prev in ways
                for prev-nodes = (ocm.osm::way-refs prev)
                for prev-first = (car prev-nodes)
                for prev-last = (car (last prev-nodes))
                when (and way-first way-last prev-first prev-last)
                do (when-let (nodes (cond
                                      ((= (id way-first) (id prev-last))
                                       (append prev-nodes (cdr way-nodes)))
                                      ((= (id way-last) (id prev-first))
                                       (append way-nodes (cdr prev-nodes)))
                                      ((= (id way-first) (id prev-first))
                                       (append (reverse way-nodes) (cdr prev-nodes)))
                                      ((= (id way-last) (id prev-last))
                                       (append prev-nodes (cdr (reverse way-nodes))))
                                      ))
                     (setf (ocm.osm::way-refs prev) nodes)
                     (return prev)))))
    (loop with inner-ways and outer-ways
       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)
       for parts = (if (equal "inner" mem-role) inner-ways outer-ways)
       when (ocm.osm::way-p mem)
       unless (try-attach mem parts)
       do (let ((new-way (ocm.osm::make-way :id (id mem)
                                            :refs (copy-list (ocm.osm::way-refs mem)))))
            (if (equal "inner" mem-role) (push new-way inner-ways) (push new-way outer-ways)))
       finally (return (ocm.osm::make-rel
                        :id (id rel) :tags (ocm.osm::obj-tags rel)
                        :memids  (append outer-ways inner-ways)
                        :roles (append (loop for w in outer-ways collect "outer")
                                       (loop for w in inner-ways collect "inner"))
                        :types (append (loop for w in outer-ways collect :way)
                                       (loop for w in inner-ways collect :way)))))))

(defun osm-fix (obj)
  (cond
    ((multipoly-p obj) (fix-multipoly obj))
    (:otherwise obj)))

(defun load-test-objects ()
  (setf *objects* nil)
  (ocm.osm::with-related (obj "spb.osm.pbf" '(
                                              (nil "natural" "water")
                                              (nil "natural" "wood")
                                              (nil "natural" "scrub")
                                              (nil "highway" "primary")
                                              (nil "highway" "secondary")))
    (push (osm-fix obj) *objects*)))

(defparameter +granularity+ (expt 10 8))
(defun node-x (node)
  (float (/ (ocm.osm::node-lon node) +granularity+)))
(defun node-y (node)
  (float (-  (/ (ocm.osm::node-lat 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+ '(150 100 0 255))
(defparameter +highway-primary-color+ '(150 30 0 255))
(defparameter +strokes+
  `(
    (((:way "lanes" "5")) :color ,+highway-primary-color+ :width 0.005)
    (((:way "lanes" "3")) :color ,+highway-primary-color+ :width 0.004)
    (((:way "highway" "primary")) :color ,+highway-primary-color+ :width 0.003)
    (((:way "highway")) :color ,+highway-color+ :width 0.001)))

(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*)
  (if hole
      (%nvg:path-winding *context* (cffi:foreign-bitfield-value '%nvg:solidity :hole))
      (apply-fill tags))
  (%nvg:fill *context*))

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

(defun closed-p (nodes)
  (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)))))

(defun area-p (nodes tags)
  (and (closed-p nodes)
       (not (ocm.osm::query-match2 +closed-lines+ :way tags))))

(defun multipoly-p (rel)
  (and (ocm.osm::rel-p rel)
       (equal (aget (tags rel) "type")
              "multipolygon")))

(defun render-way (nodes tags)
  (if (area-p nodes tags)
      (render-poly nodes tags)
      (render-line nodes tags)))

(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)
                     (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 (multipoly-p obj)
             (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 *objects*)

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

(defvar *pressed-keys* nil)
(defun process-keys ()
  (when (member %glfw:+key-left+ *pressed-keys*) (incf *pos-x* +translate-step+))
  (when (member %glfw:+key-right+ *pressed-keys*) (decf *pos-x* +translate-step+))
  (when (member %glfw:+key-up+ *pressed-keys*) (incf *pos-y* +translate-step+))
  (when (member %glfw:+key-down+ *pressed-keys*) (decf *pos-y* +translate-step+))
  (when (member %glfw:+key-minus+ *pressed-keys*) (decf *scale* +scale-step+))
  (when (member %glfw:+key-equal+ *pressed-keys*) (incf *scale* +scale-step+)))

(defparameter +translate-step+ 80f0)
(defparameter +scale-step+ 0.3)
(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+)
    (pushnew key *pressed-keys*)
    (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+) (incf *pos-x* +translate-step+))
      ((eql key %glfw:+key-right+) (decf *pos-x* +translate-step+))
      ((eql key %glfw:+key-up+) (incf *pos-y* +translate-step+))
      ((eql key %glfw:+key-down+) (decf *pos-y* +translate-step+))
      ((eql key %glfw:+key-minus+) (decf *scale* +scale-step+))
      ((eql key %glfw:+key-equal+) (incf *scale* +scale-step+))))
  (when (eql action %glfw:+release+)
    (setf *pressed-keys* (delete key *pressed-keys*)))
  (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*))
  (gl:viewport 0 0 *frame-width* *frame-height*))

(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*)))

(glfw::define-error-callback on-error (err desc)
  (format *error-output* "GLFW error ~A: ~A~%" err desc))

(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 ()
    (%glfw:set-error-callback (cffi:callback on-error))
    (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*))
      (gl:viewport 0 0 *frame-width* *frame-height*)

      ;; reset
      (setf *scale* 540f0
            *pos-x* -162910.0
            *pos-y* 324540.0)

      ;; 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)

                ;; Step
                  (process-keys)

                  ;; 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)))
  )