phoros-js.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011, 2012 Bert Burgemeister
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License along
  15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17
  18 (in-package :phoros)
  19
  20 (hunchentoot:define-easy-handler (phoros.js) ()
  21   "Serve some Javascript."
  22   (when (hunchentoot:session-value 'authenticated-p)
  23     (ps*
  24      '(progn
  25        (setf debug-info (@ *open-layers *console info))
  26
  27        (defmacro inner-html-with-id (id)
  28          "innerHTML of element with id=\"id\"."
  29          `(chain document (get-element-by-id ,id) inner-h-t-m-l))
  30
  31        (defmacro value-with-id (id)
  32          "Value of element with id=\"id\"."
  33          `(chain document (get-element-by-id ,id) value))
  34
  35        (defmacro checkbox-status-with-id (id)
  36          "Whether checkbox with id=\"id\" is checked or not."
  37          `(chain document (get-element-by-id ,id) checked))
  38
  39        (defvar *help-topics*
  40          (create
  41           :user-role
  42           (who-ps-html
  43            (:p "User role.  \"Read\" can't write or modify anything.
  44            \"Write\" may write user points and edit/delete their own
  45            ones (and ownerless points). \"Admin\" may write user
  46            points and edit/delete points written by anyone."))
  47           :presentation-project-name
  48           (who-ps-html
  49            (:p "Presentation project name."))
  50           :presentation-project-emptiness
  51           (who-ps-html
  52            (:p "This presentation project is empty.  You can't do much
  53            with it."))
  54           :recommend-fresh-login
  55           (who-ps-html
  56            (:p "Sorry, but you are no longer authenticated.  Your
  57            session may have expired due to prolonged inactivity, or an
  58            administrator has kicked you out by restarting the server.")
  59            (:p "Please repeat the login process."))
  60           :caching-indicator
  61           (who-ps-html
  62            (:p "Caching images.")
  63            (:p "As I'm currently idle, I'm preemptively putting images
  64            into your browser's cache which later on may help speed up
  65            things a bit.")
  66            (:p "Type")
  67            (:code "about:cache?device=disk")
  68            (:p "into your address bar to see what's going on there.")
  69            (:p "Your browser cache size should be set to 2000 GB or
  70            bigger. Bigger is better."))
  71           :phoros-version
  72           (who-ps-html
  73            (:p "Phoros version.")
  74            (:p "In a version string A.B.C, changes in A denote
  75            incompatible changes in data (you can't access a database
  76            set up by a different version of Phoros); changes in B mean
  77            user-visible changes in feature set; changes in C denote
  78            bug fixes and minor improvements."))
  79           :h2-controls
  80           (who-ps-html
  81            (:p "Current action."))
  82           :multiple-points-phoros-controls
  83           (who-ps-html
  84            (:p "Try reading the text under mouse pointer."))
  85           :delete-point-button
  86           (who-ps-html
  87            (:p "Delete current point."))
  88           :finish-point-button
  89           (who-ps-html
  90            (:p "Store user point with its attribute,
  91            numeric-description, description, and auxiliary data into
  92            database; warn if the given set of attributes isn't unique."))
  93           :suggest-unique-button
  94           (who-ps-html
  95            (:h3 "Non-unique set of user point attributes")
  96            (:p "Recommend a set of user point attributes that is
  97            unique among the currently defined user points, preferably
  98            by incrementing a portion of attribute numeric-description
  99            that looks like a number."))
 100           :force-duplicate-button
 101           (who-ps-html
 102            (:h3 "Non-unique set of user point attributes")
 103            (:p "Store user point with its attribute,
 104            numeric-description, description, and auxiliary data into
 105            database; don't care whether the given set of attributes is
 106            unique."))
 107           :download-user-points-button
 108           (who-ps-html
 109            (:p "Download all user points as GeoJSON-fomatted text
 110            file.  Do this regularly if you don't want to lose your
 111            work due to server crashes or major Phoros updates.")
 112            (:p "Points saved this way can be fed back into your
 113            project using the command line interface (on server or on
 114            any other host where the database is reachable)."))
 115           :point-attribute
 116           (who-ps-html
 117            (:h3 "\"attribute\"")
 118            (:p "The standard ones, polygon, polyline, and solitary are
 119            rendered as asterisk, square, and triangle respectively.
 120            Anything else is rendered as an X."))
 121           :point-description
 122           (who-ps-html
 123            (:h3 "\"description\"")
 124            (:p "Optional textual description of the set of user points
 125            the current point belongs to."))
 126           :point-numeric-description
 127           (who-ps-html
 128            (:h3 "\"numeric-description\"")
 129            (:p "Optional description of the current user point.  It is
 130            occasionally used to label representations of this point in
 131            streetmap and in images.")
 132            (:p "If parts of it look like numbers, the leftmost such
 133            part is automatically incremented during first click into
 134            an image."))
 135           :point-creation-date
 136           (who-ps-html
 137            (:p "Creation date of current user point.  Will be updated
 138            when you change this point."))
 139           :include-aux-data
 140           (who-ps-html
 141            (:p "Check this if the user point being created is to
 142            include auxiliary data."))
 143           :aux-point-distance
 144           (who-ps-html
 145            (:p "Select a set of auxiliary data, either by its distance
 146            (in metres) from the current estimated position, or by
 147            clicking its representation in streetmap."))
 148           :aux-data
 149           (who-ps-html
 150            (:p "Auxiliary data connected to this presentation project;
 151            all the numeric values followed by all the text values if
 152            any."))
 153           :creator
 154           (who-ps-html
 155            (:p "Creator of current user point.  Will be updated when
 156            you change this point."))
 157           :remove-work-layers-button
 158           (who-ps-html
 159            (:p "Discard the current, unstored user point or unselect
 160            any selected user points.  Zoom out all images. Keep
 161            the rest of the workspace untouched."))
 162           :blurb-button
 163           (who-ps-html
 164            (:p "View some info about Phoros."))
 165           :logout-button
 166           (who-ps-html
 167            (:p "Finish this session after storing current streetmap
 168            zoom status and your cursor position.")
 169            (:p "Fresh login is required to continue."))
 170           :streetmap
 171           (who-ps-html
 172            (:p "Clicking into the streetmap fetches images which most
 173            probably feature the clicked point.")
 174            (:p "To pan the map, drag the mouse.  To zoom, spin the
 175            mouse wheel, or hold shift down whilst dragging a box, or
 176            double-click (shift double-click for larger zoom steps) a
 177            point of interest."))
 178           :image
 179           (who-ps-html
 180            (:p "Clicking into an image sets or resets the active point
 181            there.  Once a feature is marked by active points in more
 182            than one image, the estimated position is calculated.")
 183            (:p "To pan an image, drag the mouse.  To zoom, spin the
 184            mouse wheel, or hold shift down whilst dragging a box, or
 185            double-click (shift double-click for larger zoom steps) a
 186            point of interest."))
 187           ol-Control-Pan-West-Item-Inactive
 188           (who-ps-html
 189            (:p "Move viewport left."))
 190           ol-Control-Pan-East-Item-Inactive
 191           (who-ps-html
 192            (:p "Move viewport right."))
 193           ol-Control-Pan-North-Item-Inactive
 194           (who-ps-html
 195            (:p "Move viewport up."))
 196           ol-Control-Pan-South-Item-Inactive
 197           (who-ps-html
 198            (:p "Move viewport down."))
 199           ol-Control-Zoom-In-Item-Inactive
 200           (who-ps-html
 201            (:p "Zoom in."))
 202           ol-Control-Zoom-Out-Item-Inactive
 203           (who-ps-html
 204            (:p "Zoom out."))
 205           streetmap-Zoom-To-Max-Extent-Item-Inactive
 206           (who-ps-html
 207            (:p "Zoom to the extent of presentation project."))
 208           ol-Control-Zoom-To-Max-Extent-Item-Inactive
 209           (who-ps-html
 210            (:p "Zoom out completely, restoring the original view."))
 211           :zoom-images-to-max-extent
 212           (who-ps-html
 213            (:p "Zoom all images out completely, restoring the original
 214            view."))
 215           :no-footprints-p
 216           (who-ps-html
 217            (:p "I haven't been able to display a set of images that
 218            cover a common area because I couldn't find the necessary
 219            information.  As a fallback, I'm displaying a set of images
 220            with points of view close to the point you selected.")
 221            (:p "The server is probably trying to remedy this problem
 222            but this may take some time."))
 223           :auto-zoom
 224           (who-ps-html
 225            (:h3 "Auto Zoom")
 226            (:p "Check this to automatically zoom into images once they
 227            get an estimated position."))
 228           :brighten-images
 229           (who-ps-html
 230            (:p "Check this to have underexposed images brightened up.")
 231            (:p "Brightening starts with the next set of images and may
 232            slow things down a bit."))
 233           :walk-mode
 234           (who-ps-html
 235            (:p "Check this to snap your current position onto a line
 236            along points of auxiliary data, and to keep streetmap
 237            centered around current position."))
 238           :decrease-step-size
 239           (who-ps-html
 240            (:p "Decrease step size.  Double-click to decrease harder."))
 241           :step-size
 242           (who-ps-html
 243            (:p "Step size in metres.  Click to increase; double-click
 244            to increase harder."))
 245           :increase-step-size
 246           (who-ps-html
 247            (:p "Increase step size.  Double-click to increase harder."))
 248           :step-button
 249           (who-ps-html
 250            (:p "Move your position by one step on a line along points
 251            of auxiliary data.  Double-click to change direction."))
 252           :image-layer-switcher
 253           (who-ps-html
 254            (:p "Toggle display of image."))
 255           :image-usable
 256           (who-ps-html
 257            (:p "No photogrammetric survey possible as there isn't any
 258            usable calibration data available for this image.")
 259            (:p "This means no image footprints can be calculated
 260            either which prevents me from selecting images covering a
 261            common area."))
 262           :image-trigger-time
 263           (who-ps-html
 264            (:p "Time this image was taken."))
 265           base-layers-div
 266           (who-ps-html
 267            (:p "Choose a background streetmap."))
 268           data-layers-div
 269           (who-ps-html
 270            (:p "Toggle visibility of data layers."))
 271           :streetmap-overview
 272           (who-ps-html
 273            (:p "Click to re-center streetmap, or drag the red
 274            rectangle."))
 275           :streetmap-mouse-position
 276           (who-ps-html
 277            (:p "Cursor position in geographic coordinates when cursor
 278            is in streetmap."))
 279           :h2-help
 280           (who-ps-html
 281            (:p "Hints on Phoros' displays and controls are shown here
 282            while hovering over the respective elements."))))
 283
 284        (defun add-help-topic (topic element)
 285          "Add mouse events to DOM element that initiate display of a
 286          help message."
 287          (when element
 288            (setf (@ element onmouseover)
 289                  ((lambda (x)
 290                     (lambda () (show-help x)))
 291                   topic))
 292            (setf (@ element onmouseout) show-help)))
 293
 294        (defun add-help-events ()
 295          "Add mouse events to DOM elements that initiate display of a
 296          help message."
 297          (for-in
 298           (topic *help-topics*)
 299           (add-help-topic topic (chain document (get-element-by-id topic)))
 300           (dolist (element (chain document (get-elements-by-class-name topic)))
 301             (add-help-topic topic element))))
 302
 303        (defun show-help (&optional topic)
 304          "Put text on topic into help-display"
 305          (setf (inner-html-with-id "help-display")
 306                (let ((help-body (getprop *help-topics* topic)))
 307                  (if (undefined help-body)
 308                      ""
 309                      help-body))))
 310
 311        (defvar *click-control*
 312          (chain
 313           *open-layers
 314           (*class
 315            (@ *open-layers *control)
 316            (create
 317             :initialize
 318             (lambda (options)
 319               (chain *open-layers
 320                      *control
 321                      prototype
 322                      initialize
 323                      (apply this arguments))
 324               (setf (@ this handler)
 325                     (new (chain *open-layers
 326                                 *handler
 327                                 (*click this
 328                                         (create
 329                                          :click (@ this trigger)))))))))))
 330
 331        (defvar +unix-epoch+ (lisp *unix-epoch*)
 332          "Seconds between Lisp epoch and UNIX epoch.")
 333        (defvar +geographic+
 334          (new (chain *open-layers (*projection "EPSG:4326"))))
 335        (defvar +spherical-mercator+
 336          (new (chain *open-layers (*projection "EPSG:900913"))))
 337
 338        (defvar +proxy-root+
 339          (lisp *proxy-root*)
 340          "First element of URL path; defaults to phoros but may be
 341          turned into something different by an HTTP proxy
 342          definition.")
 343
 344        (defvar +user-name+ (lisp (hunchentoot:session-value 'user-name))
 345          "User's (short) name.")
 346        (defvar +user-role+ (lisp (string-downcase (hunchentoot:session-value
 347                                                    'user-role)))
 348          "User's permissions.")
 349
 350        (defvar +presentation-project-bbox-text+
 351          (lisp (hunchentoot:session-value 'presentation-project-bbox)))
 352
 353        (defvar +presentation-project-bounds+
 354          (chain (new (chain *open-layers
 355                             *bounds
 356                             (from-string
 357                              (or +presentation-project-bbox-text+
 358                                  "-180,-89,180,89"))))
 359                 (transform +geographic+ +spherical-mercator+))
 360          "Bounding box of the entire presentation project.")
 361
 362        (defvar +aux-data-p+
 363          (lisp (hunchentoot:session-value 'aux-data-p)))
 364
 365        (defvar +aux-numeric-labels+
 366          (lisp (when *aux-numeric-labels*
 367                  (coerce *aux-numeric-labels* 'vector))))
 368
 369        (defvar +aux-text-labels+
 370          (lisp (when *aux-text-labels*
 371                  (coerce *aux-text-labels* 'vector))))
 372
 373        (defvar *images* (array) "Collection of the photos currently shown.")
 374
 375        (defvar *streetmap* undefined
 376          "The streetmap shown to the user.")
 377
 378        ;; (defvar *point-attributes-select* undefined
 379        ;;   "The HTML element for selecting user point attributes.")
 380
 381        (defvar *aux-point-distance-select* undefined
 382          "The HTML element for selecting one of a few nearest
 383          auxiliary points.")
 384
 385        (defvar *global-position* undefined
 386          "Coordinates of the current estimated position")
 387
 388        (defvar *linestring-step-ratio* 4
 389          "Look for auxiliary points to include into linestring within
 390          a radius of *linestring-step-ratio* multilied by multiplied by
 391          step-size.")
 392
 393        (defvar *current-nearest-aux-point*
 394          (create attributes (create aux-numeric undefined
 395                                     aux-text undefined))
 396          "Attributes of currently selected point of auxiliary data.")
 397
 398        (defvar *bbox-strategy* (@ *open-layers *strategy *bbox*))
 399        (setf (@ *bbox-strategy* prototype ratio) 1.5)
 400        (setf (@ *bbox-strategy* prototype res-factor) 1.5)
 401
 402        (defvar *json-parser* (new (chain *open-layers *format *json*)))
 403
 404        (defvar *geojson-parser* (new (chain *open-layers *format *geo-j-s-o-n)))
 405
 406        (defvar *geojson-format* (chain *open-layers *format *geo-j-s-o-n))
 407        (setf (@ *geojson-format* prototype ignore-extra-dims)
 408         t)                              ;doesn't handle height anyway
 409        (setf (@ *geojson-format* prototype external-projection)
 410         +geographic+)
 411        (setf (@ *geojson-format* prototype internal-projection)
 412         +geographic+)
 413
 414        (defvar *wkt-parser*
 415          (new (chain *open-layers
 416                      *format
 417                      (*wkt*
 418                       (create external-projection +geographic+
 419                               internal-projection +spherical-mercator+)))))
 420
 421        (defvar *http-protocol* (chain *open-layers *protocol *http*))
 422        (setf (chain *http-protocol* prototype format) (new *geojson-format*))
 423
 424        (defvar *pristine-images-p* t
 425          "T if none of the current images has been clicked into yet.")
 426
 427        (defvar *current-user-point* undefined
 428          "The currently selected user-point.")
 429
 430        (defun write-permission-p (&optional (current-owner +user-name+))
 431          "Nil if current user can't edit stuff created by
 432          current-owner or, without arguments, new stuff."
 433          (or (equal +user-role+ "admin")
 434              (and (equal +user-role+ "write")
 435                   (or (equal +user-name+ current-owner)
 436                       (not current-owner)))))
 437
 438        (defun *image ()
 439          "Anything necessary to deal with a photo."
 440          (setf (@ this map)
 441                (new
 442                 (chain
 443                  *open-layers
 444                  (*map
 445                   (create projection +spherical-mercator+
 446                           all-overlays t
 447                           controls (array (new (chain *open-layers
 448                                                       *control
 449                                                       (*navigation)))))))))
 450          (setf (@ this dummy) false) ;TODO why? (omitting splices map components directly into *image)
 451          )
 452
 453        (setf (@ *image prototype delete-photo)
 454         delete-photo)
 455        (setf (@ *image prototype photop)
 456         photop)
 457        (setf (@ *image prototype show-photo)
 458         show-photo)
 459        (setf (@ *image prototype draw-epipolar-line)
 460         draw-epipolar-line)
 461        (setf (@ *image prototype draw-active-point)
 462         draw-active-point)
 463        (setf (@ *image prototype draw-estimated-positions)
 464         draw-estimated-positions)
 465
 466        (defun photo-path (photo-parameters)
 467          "Create from stuff found in photo-parameters and in checkbox
 468          brighten-images-p a path with parameters for use in an image
 469          url."
 470          (+ "/" +proxy-root+
 471             "/lib/photo/"
 472             (@ photo-parameters directory) "/"
 473             (@ photo-parameters filename) "/"
 474             (@ photo-parameters byte-position) ".png"
 475             "?mounting-angle=" (@ photo-parameters mounting-angle)
 476             "&bayer-pattern=" (@ photo-parameters bayer-pattern)
 477             "&color-raiser=" (@ photo-parameters color-raiser)
 478             (if (checkbox-status-with-id "brighten-images-p")
 479                 "&brightenp"
 480                 "")))
 481
 482        (defun has-layer-p (map layer-name)
 483          "False if map doesn't have a layer called layer-name."
 484          (chain map (get-layers-by-name layer-name) length))
 485
 486        (defun some-active-point-p ()
 487          "False if no image in *images* has an Active Point."
 488          (loop
 489             for i across *images*
 490             sum (has-layer-p (@ i map) "Active Point")))
 491
 492        (defun remove-layer (map layer-name)
 493          "Destroy layer layer-name in map."
 494          (when (has-layer-p map layer-name)
 495            (chain map (get-layers-by-name layer-name) 0 (destroy))))
 496
 497        (defun remove-any-layers (layer-name)
 498          "Destroy in all *images* and in *streetmap* the layer named layer-name."
 499          (loop
 500             for i across *images* do
 501             (remove-layer (@ i map) layer-name))
 502          (remove-layer *streetmap* layer-name))
 503
 504        (defun reset-controls ()
 505          (reveal-element-with-id "real-phoros-controls")
 506          (hide-element-with-id "multiple-points-phoros-controls")
 507          (disable-element-with-id "finish-point-button")
 508          (disable-element-with-id "delete-point-button")
 509          (disable-element-with-id "remove-work-layers-button")
 510          (setf (inner-html-with-id "h2-controls") "Create Point")
 511          (setf (inner-html-with-id "creator") nil)
 512          (setf (inner-html-with-id "point-creation-date") nil)
 513          (hide-aux-data-choice)
 514          (setf (inner-html-with-id "aux-numeric-list") nil)
 515          (setf (inner-html-with-id "aux-text-list") nil))
 516
 517        (defun disable-streetmap-nearest-aux-points-layer ()
 518          "Get (@ *streetmap* nearest-aux-points-layer) out of the way,
 519          I.e., remove features and disable feature select control so
 520          it won't shadow any other control."
 521          (chain *streetmap* nearest-aux-points-layer (remove-all-features))
 522          (chain *streetmap* nearest-aux-points-select-control (deactivate))
 523          (chain *streetmap* user-points-select-control (activate)))
 524
 525        (defun reset-layers-and-controls ()
 526          "Destroy user-generated layers in *streetmap* and in all
 527          *images*, and put controls into pristine state."
 528          (remove-any-layers "Epipolar Line")
 529          (remove-any-layers "Active Point")
 530          (remove-any-layers "Estimated Position")
 531          (remove-any-layers "User Point")
 532          (chain *streetmap* user-points-select-control (unselect-all))
 533          (disable-streetmap-nearest-aux-points-layer)
 534          (when (and (not (equal undefined *current-user-point*))
 535                     (@ *current-user-point* layer))
 536            (chain *streetmap*
 537                   user-points-select-control
 538                   (unselect *current-user-point*)))
 539          (reset-controls)
 540          (setf *pristine-images-p* t)
 541          (zoom-images-to-max-extent))
 542
 543        (defun enable-element-with-id (id)
 544          "Activate HTML element with id=\"id\".  Return t if element
 545          was greyed out before."
 546          (prog1
 547              (chain document (get-element-by-id id) disabled)
 548            (setf (chain document (get-element-by-id id) disabled) nil)))
 549
 550        (defun disable-element-with-id (id)
 551          "Grey out HTML element with id=\"id\".  Return t if element
 552          was active before."
 553          (prog1
 554              (not (chain document (get-element-by-id id) disabled))
 555            (setf (chain document (get-element-by-id id) disabled) t)))
 556
 557        (defun hide-element-with-id (id)
 558          "Hide HTML element wit id=\"id\"."
 559          (setf (chain document (get-element-by-id id) style display)
 560                "none"))
 561
 562        (defun reveal-element-with-id (id)
 563          "Reveal HTML element wit id=\"id\"."
 564          (setf (chain document (get-element-by-id id) style display)
 565                ""))
 566
 567        (defun hide-aux-data-choice ()
 568          "Disable selector for auxiliary data."
 569          ;;(disable-element-with-id "include-aux-data-p")
 570          (hide-element-with-id "include-aux-data")
 571          (hide-element-with-id "aux-point-distance")
 572          (setf (chain document
 573                       (get-element-by-id "aux-point-distance")
 574                       options
 575                       length)
 576                0))
 577
 578        (defun refresh-layer (layer)
 579          "Have layer re-request and redraw features."
 580          (chain layer (refresh (create :force t))))
 581
 582        (defun present-photos ()
 583          "Handle the response triggered by request-photos-for-point."
 584          (let ((photo-parameters
 585                 (chain *json-parser*
 586                        (read (@ *streetmap*
 587                                 photo-request-response response-text)))))
 588            (loop
 589               for i across *images*
 590               do (chain i (delete-photo)))
 591            (if (@ photo-parameters 0 footprintp)
 592                (hide-element-with-id "no-footprints-p")
 593                (reveal-element-with-id "no-footprints-p"))
 594            (loop
 595               for p across photo-parameters
 596               for i across *images*
 597               do
 598               (setf (@ i photo-parameters) p)
 599               (chain i (show-photo)))))
 600
 601        (defun recommend-fresh-login ()
 602          "Notify user about invalid authentication."
 603          (setf (inner-html-with-id "recommend-fresh-login")
 604                "(not authenticated)")
 605          (disable-element-with-id "download-user-points-button")
 606          (disable-element-with-id "blurb-button")
 607          (hide-element-with-id "phoros-controls")
 608          (hide-element-with-id "images"))
 609
 610        (defun consolidate-combobox (combobox-id)
 611          "Help faking a combobox: copy selected option into input."
 612          (let* ((combobox-select (+ combobox-id "-select"))
 613                 (combobox-input (+ combobox-id "-input"))
 614                 (combobox-selected-index
 615                  (chain document
 616                         (get-element-by-id combobox-select)
 617                         selected-index)))
 618            (when (< -1 combobox-selected-index)
 619              (setf (value-with-id combobox-input)
 620                    (getprop (chain document
 621                                    (get-element-by-id combobox-select)
 622                                    options)
 623                             combobox-selected-index
 624                             'value)))
 625            (chain document
 626                   (get-element-by-id combobox-input)
 627                   (focus))))
 628
 629        (defun unselect-combobox-selection (combobox-id)
 630          "Help faking a combobox: unset selected option so any
 631          selection there will trigger an onchange event."
 632          (let ((combobox-select (+ combobox-id "-select")))
 633            (setf (chain document
 634                         (get-element-by-id combobox-select)
 635                         selected-index)
 636                  -1)))
 637
 638        (defun stuff-combobox (combobox-id values &optional (selection -1))
 639          "Stuff combobox with values.  If selection is a non-negative
 640          integer, select the respective item."
 641          (let ((combobox-select (+ combobox-id "-select"))
 642                (combobox-input (+ combobox-id "-input")))
 643            (setf (chain document
 644                         (get-element-by-id combobox-select)
 645                         options
 646                         length)
 647                  0)
 648
 649            (loop for i in values do
 650                 (setf combobox-item
 651                       (chain document (create-element "option")))
 652                 (setf (@ combobox-item text) i)
 653                 (chain document
 654                        (get-element-by-id combobox-select)
 655                        (add combobox-item null)))
 656            (setf (chain document
 657                         (get-element-by-id combobox-select)
 658                         selected-index)
 659                  selection)
 660            (consolidate-combobox combobox-id)))
 661
 662        (defun stuff-user-point-comboboxes (&optional selectp)
 663          "Stuff user point attribute comboboxes with sensible values.
 664          If selectp it t, select the most frequently used one."
 665          (let* ((response
 666                  (chain *json-parser*
 667                         (read (@ *streetmap*
 668                                  user-point-choice-response response-text))))
 669                 (attributes
 670                  (chain response attributes (map (lambda (x)
 671                                                    (@ x attribute)))))
 672                 (descriptions
 673                  (chain response descriptions (map (lambda (x)
 674                                                      (@ x description)))))
 675                 (best-used-attribute -1)
 676                 (best-used-description -1))
 677            (when selectp
 678              (loop
 679                 with maximum = 0
 680                 for i across (@ response descriptions)
 681                 for k from 0
 682                 do (when (< maximum (@ i count))
 683                      (setf maximum (@ i count))
 684                      (setf best-used-description k)))
 685              (loop
 686                 with maximum = 0
 687                 for i across (@ response attributes)
 688                 for k from 0
 689                 do (when (< maximum (@ i count))
 690                      (setf maximum (@ i count))
 691                      (setf best-used-attribute k))))
 692            (stuff-combobox
 693             "point-attribute" attributes best-used-attribute)
 694            (stuff-combobox
 695             "point-description" descriptions best-used-description)))
 696
 697        (defun request-user-point-choice (&optional selectp)
 698          "Stuff user point attribute comboboxes with sensible values.
 699          If selectp it t, select the most frequently used one."
 700          (setf (@ *streetmap* user-point-choice-response)
 701                (chain
 702                 *open-layers
 703                 *Request
 704                 (*POST*
 705                  (create :url (+ "/" +proxy-root+
 706                                  "/lib/user-point-attributes.json")
 707                          :data nil
 708                          :headers (create "Content-type" "text/plain")
 709                          :success (lambda ()
 710                                     (stuff-user-point-comboboxes selectp))
 711                          :failure recommend-fresh-login)))))
 712
 713        (defun request-photos-after-click (event)
 714          "Handle the response to a click into *streetmap*; fetch photo
 715          data.  Set or update streetmap cursor."
 716          (request-photos (chain *streetmap*
 717                                 (get-lon-lat-from-pixel (@ event xy)))))
 718
 719        (defun request-photos (lonlat)
 720          "Fetch photo data for a point near lonlat.  Set or update
 721          streetmap cursor."
 722          (setf (@ *streetmap* clicked-lonlat) lonlat)
 723          (if (checkbox-status-with-id "walk-p")
 724              (request-aux-data-linestring-for-point
 725               (@ *streetmap* clicked-lonlat))
 726              (request-photos-for-point (@ *streetmap* clicked-lonlat)))
 727          (request-cache-fodder (@ *streetmap* clicked-lonlat)))
 728
 729        (defun request-aux-data-linestring-for-point (lonlat-spherical-mercator)
 730          "Fetch a linestring along auxiliary points near
 731          lonlat-spherical-mercator."
 732          (let ((lonlat-geographic
 733                 (chain lonlat-spherical-mercator
 734                        (clone)
 735                        (transform +spherical-mercator+ +geographic+))))
 736            (request-aux-data-linestring (@ lonlat-geographic lon)
 737                                         (@ lonlat-geographic lat)
 738                                         (* *linestring-step-ratio*
 739                                            (step-size-degrees))
 740                                         (step-size-degrees))))
 741
 742        (defun request-photos-for-point (lonlat-spherical-mercator)
 743          "Fetch photo data near lonlat-spherical-mercator; set or
 744          update streetmap cursor."
 745          (disable-element-with-id "finish-point-button")
 746          (disable-element-with-id "remove-work-layers-button")
 747          (remove-any-layers "Estimated Position")
 748          (disable-streetmap-nearest-aux-points-layer)
 749          (reset-controls)
 750          (let* ((lonlat-geographic
 751                  (chain lonlat-spherical-mercator
 752                         (clone)
 753                         (transform +spherical-mercator+ +geographic+)))
 754                 (content
 755                  (chain *json-parser*
 756                         (write
 757                          (create :longitude (@ lonlat-geographic lon)
 758                                  :latitude (@ lonlat-geographic lat)
 759                                  :zoom (chain *streetmap* (get-zoom))
 760                                  :count (lisp *number-of-images*))))))
 761            (chain *streetmap*
 762                   cursor-layer
 763                   (remove-all-features))
 764            (chain *streetmap*
 765                   cursor-layer
 766                   (add-features
 767                    (new (chain *open-layers
 768                                *feature
 769                                (*vector
 770                                 (new (chain
 771                                       *open-layers
 772                                       *geometry
 773                                       (*point (@ lonlat-spherical-mercator
 774                                                  lon)
 775                                               (@ lonlat-spherical-mercator
 776                                                  lat)))))))))
 777            (chain *streetmap*
 778                   overview-cursor-layer
 779                   (remove-all-features))
 780            (chain *streetmap*
 781                   overview-cursor-layer
 782                   (add-features
 783                    (new (chain *open-layers
 784                                *feature
 785                                (*vector
 786                                 (new (chain
 787                                       *open-layers
 788                                       *geometry
 789                                       (*point (@ lonlat-spherical-mercator
 790                                                  lon)
 791                                               (@ lonlat-spherical-mercator
 792                                                  lat)))))))))
 793            (setf (@ *streetmap* photo-request-response)
 794                  (chain
 795                   *open-layers
 796                   *Request
 797                   (*POST*
 798                    (create
 799                     :url (+ "/" +proxy-root+ "/lib/nearest-image-data")
 800                     :data content
 801                     :headers (create "Content-type" "text/plain"
 802                                      "Content-length" (@ content length))
 803                     :success present-photos
 804                     :failure recommend-fresh-login))))))
 805
 806        (defvar *cache-stuffer*
 807          (create xhr undefined          ;instance of XMLHttpRequest
 808                  cache-fodder-request-response undefined
 809                  photo-url-ingredients undefined
 810                  index undefined        ;current element of
 811                                         ; photo-url-ingredients
 812                  caching-photo-p nil
 813                  cache-size (* 2084000 1024)
 814                                         ;we assume cache-size is set
 815                                         ; to 2000MB by browser user
 816                  average-image-size undefined
 817                  current-center undefined
 818                  cache-photo-timeout undefined
 819                  request-cache-fodder-group-timeout undefined)
 820          "Things used to preemptively stuff the browser cache.")
 821
 822        (defun request-cache-fodder (lonlat-spherical-mercator)
 823          "Abort any previous cache stuffing activities, wait a few
 824          seconds, and start a new cache stuffing session centered at
 825          lonlat-spherical-mercator."
 826          (setf (@ *cache-stuffer* current-center)
 827                (chain lonlat-spherical-mercator
 828                       (clone)
 829                       (transform +spherical-mercator+ +geographic+)))
 830          (setf (@ *cache-stuffer* average-image-size) 0)
 831          (clear-timeout (@ *cache-stuffer* cache-photo-timeout))
 832          (clear-timeout (@ *cache-stuffer* request-cache-fodder-group-timeout))
 833          (hide-element-with-id "caching-indicator")
 834          (setf (@ *cache-stuffer* request-cache-fodder-group-timeout)
 835                (set-timeout request-cache-fodder-group 15000)))
 836
 837        (defun request-cache-fodder-group ()
 838          "Request a bunch of image url ingredients, initiate caching
 839          of the respective images.  Keep trying if unsuccessful."
 840          (let ((content
 841                 (chain *json-parser*
 842                        (write
 843                         (create
 844                          :longitude (@ *cache-stuffer* current-center lon)
 845                          :latitude (@ *cache-stuffer* current-center lat))))))
 846            (setf (@ *cache-stuffer* cache-fodder-request-response)
 847                  (chain
 848                   *open-layers
 849                   *request
 850                   (*post*
 851                    (create
 852                     :url (+ "/" +proxy-root+ "/lib/nearest-image-urls")
 853                     :data content
 854                     :headers (create "Content-type" "text/plain"
 855                                      "Content-length" (@ content length))
 856                     :success handle-request-cache-fodder-group
 857                     :failure (lambda ()
 858                                (if (= (@ *cache-stuffer* cache-fodder-request-response status) 504)
 859                                    (progn
 860                                      (clear-timeout
 861                                       (@ *cache-stuffer*
 862                                          request-cache-fodder-group-timeout))
 863                                      (setf (@ *cache-stuffer*
 864                                               request-cache-fodder-group-timeout)
 865                                            (set-timeout request-cache-fodder-group
 866                                                         5000)))
 867                                    (recommend-fresh-login)))))))))
 868
 869        (defun handle-request-cache-fodder-group ()
 870          "Handle the response triggered by request-cache-fodder-group."
 871          (setf (@ *cache-stuffer* photo-url-ingredients)
 872                (chain *json-parser*
 873                       (read (@ *cache-stuffer*
 874                                cache-fodder-request-response
 875                                response-text))))
 876          (setf (@ *cache-stuffer* index) 0)
 877          (reveal-element-with-id "caching-indicator")
 878          (cache-photo))
 879
 880        (defun cache-photo ()
 881          "Cache another image if the previous one is done."
 882          (if (and (< (@ *cache-stuffer* index)
 883                      (length (@ *cache-stuffer* photo-url-ingredients)))
 884                   (< (* (@ *cache-stuffer* index)
 885                         (@ *cache-stuffer* average-image-size))
 886                      (* .5 (@ *cache-stuffer* cache-size))))
 887              (if (@ *cache-stuffer* caching-photo-p)
 888                  (progn
 889                    (clear-timeout (@ *cache-stuffer* cache-photo-timeout))
 890                    (setf (@ *cache-stuffer* cache-photo-timeout)
 891                          (set-timeout cache-photo 3000)))
 892                  (progn
 893                    (setf (@ *cache-stuffer* caching-photo-p) t)
 894                    (setf (@ *cache-stuffer* xhr) (new (*x-m-l-http-request)))
 895                    (chain *cache-stuffer*
 896                           xhr
 897                           (open "GET"
 898                                 (photo-path
 899                                  (aref (@ *cache-stuffer* photo-url-ingredients)
 900                                        (@ *cache-stuffer* index)))
 901                                 t))
 902                    (setf (@ *cache-stuffer* xhr onload)
 903                          (lambda (event)
 904                            (setf (@ *cache-stuffer* average-image-size)
 905                                  (/ (+ (* (@ *cache-stuffer* average-image-size)
 906                                           (@ *cache-stuffer* index))
 907                                        (@ event total)) ;bytes received
 908                                     (1+ (@ *cache-stuffer* index))))
 909                            (setf (@ *cache-stuffer* caching-photo-p) nil)
 910                            (incf (@ *cache-stuffer* index))))
 911                    ;; We do our best to have the browser use its cache.
 912                    ;; Note however that in certain cases use of the
 913                    ;; cache may be hampered by pressing the browser's
 914                    ;; reload button.
 915                    (chain *cache-stuffer*
 916                           xhr
 917                           (set-request-header
 918                            "Cache-control"
 919                            (+ "max-age=" (lisp *browser-cache-max-age*))))
 920                    (chain *cache-stuffer* xhr (send))
 921                    (clear-timeout (@ *cache-stuffer* cache-photo-timeout))
 922                    (setf (@ *cache-stuffer* cache-photo-timeout)
 923                          (set-timeout
 924                           cache-photo   ;come back quickly in case
 925                           500))))       ; photo is already in cache
 926              (hide-element-with-id "caching-indicator")))
 927
 928        (defun draw-epipolar-line ()
 929          "Draw an epipolar line from response triggered by clicking
 930          into a (first) photo."
 931          (enable-element-with-id "remove-work-layers-button")
 932          (let* ((epipolar-line
 933                  (chain *json-parser*
 934                         (read
 935                          (@ this epipolar-request-response response-text))))
 936                 (points
 937                  (chain epipolar-line
 938                         (map (lambda (x)
 939                                (new (chain *open-layers
 940                                            *geometry
 941                                            (*point
 942                                             (@ x :m) (@ x :n))))))))
 943                 (feature
 944                  (new (chain *open-layers
 945                              *feature
 946                              (*vector
 947                               (new (chain
 948                                     *open-layers
 949                                     *geometry
 950                                     (*line-string points))))))))
 951            (setf (@ feature render-intent) "temporary")
 952            (chain this epipolar-layer
 953                   (add-features feature))))
 954        ;; either *line-string or *multi-point are usable
 955
 956        (defun request-nearest-aux-points (global-position count)
 957          "Draw into streetmap the count nearest points of auxiliary
 958          data."
 959          (let ((global-position-etc global-position)
 960                content)
 961            (setf (@ global-position-etc count) count)
 962            (setf content (chain *json-parser*
 963                                 (write global-position-etc)))
 964            (setf (@ *streetmap* aux-local-data-request-response)
 965                  (chain *open-layers
 966                         *Request
 967                         (*POST*
 968                          (create :url (+ "/" +proxy-root+
 969                                          "/lib/aux-local-data")
 970                                  :data content
 971                                  :headers (create "Content-type" "text/plain"
 972                                                   "Content-length"
 973                                                   (@ content length))
 974                                  :success draw-nearest-aux-points
 975                                  :failure recommend-fresh-login))))))
 976
 977        (defun request-aux-data-linestring (longitude latitude radius step-size)
 978          "Draw into streetmap a piece of linestring threaded along the
 979          nearest points of auxiliary data inside radius."
 980          (let* ((payload (create longitude longitude
 981                                  latitude latitude
 982                                  radius radius
 983                                  step-size step-size
 984                                  azimuth (@ *streetmap*
 985                                             linestring-central-azimuth)))
 986                 (content (chain *json-parser* (write payload))))
 987            (setf (@ *streetmap* aux-data-linestring-request-response)
 988                  (chain *open-layers
 989                         *Request
 990                         (*POST*
 991                          (create :url (+ "/" +proxy-root+
 992                                          "/lib/aux-local-linestring.json")
 993                                  :data content
 994                                  :headers (create "Content-type" "text/plain"
 995                                                   "Content-length"
 996                                                   (@ content length))
 997                                  :success draw-aux-data-linestring
 998                                  :failure recommend-fresh-login))))))
 999
1000        (defun draw-estimated-positions ()
1001          "Draw into streetmap and into all images points at Estimated
1002          Position.  Estimated Position is the point returned so far
1003          from photogrammetric calculations that are triggered by
1004          clicking into another photo.  Also draw into streetmap the
1005          nearest auxiliary points to Estimated Position."
1006          (when (write-permission-p)
1007            (setf (chain document
1008                         (get-element-by-id "finish-point-button")
1009                         onclick)
1010                  (lambda () (finish-point #'store-point)))
1011            (enable-element-with-id "finish-point-button"))
1012          (let* ((estimated-positions-request-response
1013                  (chain *json-parser*
1014                         (read
1015                          (@ this
1016                             estimated-positions-request-response
1017                             response-text))))
1018                 (estimated-positions
1019                  (aref estimated-positions-request-response 1))
1020                 (estimated-position-style
1021                  (create stroke-color (chain *open-layers
1022                                              *feature
1023                                              *vector
1024                                              style "temporary" stroke-color)
1025                          point-radius 9
1026                          fill-opacity 0)))
1027            (setf *global-position*
1028                  (aref estimated-positions-request-response 0))
1029            (let ((feature
1030                   (new
1031                    (chain *open-layers
1032                           *feature
1033                           (*vector
1034                            (chain
1035                             (new (chain *open-layers
1036                                         *geometry
1037                                         (*point
1038                                          (@ *global-position* longitude)
1039                                          (@ *global-position* latitude))))
1040                             (transform +geographic+ +spherical-mercator+)))))))
1041              (setf (@ feature render-intent) "temporary")
1042              (setf (@ *streetmap* estimated-position-layer)
1043                    (new (chain *open-layers
1044                                *layer
1045                                (*vector
1046                                 "Estimated Position"
1047                                 (create display-in-layer-switcher nil)))))
1048              (setf (@ *streetmap* estimated-position-layer style)
1049                    estimated-position-style)
1050              (chain *streetmap* estimated-position-layer (add-features feature))
1051              (chain *streetmap*
1052                     (add-layer (@ *streetmap* estimated-position-layer))))
1053            (request-nearest-aux-points *global-position* 7)
1054            (loop
1055               for i in *images*
1056               for p in estimated-positions
1057               do
1058               (when p    ;otherwise a photogrammetry error has occured
1059                 (setf (@ i estimated-position-layer)
1060                       (new
1061                        (chain *open-layers
1062                               *layer
1063                               (*vector
1064                                "Estimated Position"
1065                                (create display-in-layer-switcher nil)))))
1066                 (setf (@ i estimated-position-lonlat)
1067                       (new (chain *open-layers (*lon-lat (@ p m)
1068                                                          (@ p n)))))
1069                 (setf (@ i estimated-position-layer style)
1070                       estimated-position-style)
1071                 (let* ((point
1072                         (new
1073                          (chain *open-layers *geometry (*point (@ p m)
1074                                                                (@ p n)))))
1075                        (feature
1076                         (new
1077                          (chain *open-layers *feature (*vector point)))))
1078                   (chain i map
1079                          (add-layer (@ i estimated-position-layer)))
1080                   (chain i estimated-position-layer
1081                          (add-features feature))))))
1082          (zoom-anything-to-point)
1083          (chain document
1084                 (get-element-by-id "finish-point-button")
1085                 (focus)))
1086
1087        (defun draw-nearest-aux-points ()
1088          "Draw a few auxiliary points into streetmap."
1089          (reveal-element-with-id "include-aux-data")
1090          (reveal-element-with-id "aux-point-distance")
1091          (let ((features
1092                 (chain *json-parser*
1093                        (read
1094                         (@ *streetmap*
1095                            aux-local-data-request-response
1096                            response-text))
1097                        features)))
1098            (disable-streetmap-nearest-aux-points-layer)
1099            (chain *streetmap* user-points-select-control (deactivate))
1100            (chain *streetmap* nearest-aux-points-select-control (activate))
1101            (chain *streetmap* nearest-aux-points-hover-control (activate))
1102            (setf (@ *aux-point-distance-select* options length)
1103                  0)
1104            (loop
1105               for i in features
1106               for n from 0 do
1107               (let* ((point
1108                       (chain
1109                        (new
1110                         (chain *open-layers
1111                                *geometry
1112                                (*point (@ i geometry coordinates 0)
1113                                        (@ i geometry coordinates 1))))
1114                        (transform +geographic+ +spherical-mercator+)))
1115                      (feature
1116                       (new
1117                        (chain *open-layers *feature (*vector point)))))
1118                 (setf (@ feature attributes)
1119                       (@ i properties))
1120                 (setf (@ feature fid) ;this is supposed to correspond to
1121                       n)       ; option of *aux-point-distance-select*
1122                 (chain *streetmap*
1123                        nearest-aux-points-layer
1124                        (add-features feature))
1125                 (setf aux-point-distance-item
1126                       (chain document (create-element "option")))
1127                 (setf (@ aux-point-distance-item text)
1128                       (+
1129                        "("
1130                        n ;let's hope add-features alway stores features in order of arrival
1131                        ") "
1132                        (chain *open-layers
1133                               *number
1134                               (format (@ i properties distance) 3 ""))))
1135                 (chain *aux-point-distance-select*
1136                        (add aux-point-distance-item null))))
1137            (chain *streetmap*
1138                   nearest-aux-points-select-control
1139                   (select
1140                    (chain
1141                     (elt (@ *streetmap* nearest-aux-points-layer features)
1142                          0))))
1143            (enable-element-with-id "aux-point-distance")))
1144
1145        (defun draw-aux-data-linestring ()
1146          "Draw a piece of linestring along a few auxiliary points into
1147          streetmap.  Pan streetmap accordingly."
1148          (let* ((data
1149                  (@ *streetmap*
1150                     aux-data-linestring-request-response
1151                     response-text))
1152                 (linestring-wkt
1153                  (chain *json-parser* (read data) linestring))
1154                 (current-point-wkt
1155                  (chain *json-parser* (read data) current-point))
1156                 (previous-point-wkt
1157                  (chain *json-parser* (read data) previous-point))
1158                 (next-point-wkt
1159                  (chain *json-parser* (read data) next-point))
1160                 (azimuth
1161                  (chain *json-parser* (read data) azimuth))
1162                 (linestring
1163                  (chain *wkt-parser* (read linestring-wkt)))
1164                 (current-point
1165                  (chain *wkt-parser* (read current-point-wkt)))
1166                 (previous-point
1167                  (chain *wkt-parser* (read previous-point-wkt)))
1168                 (next-point
1169                  (chain *wkt-parser* (read next-point-wkt)))
1170                 (current-point-lonlat
1171                  (new (chain *open-layers
1172                              (*lon-lat (@ current-point geometry x)
1173                                        (@ current-point geometry y))))))
1174            (chain *streetmap* (pan-to current-point-lonlat))
1175            (setf (@ *streetmap* linestring-central-azimuth) azimuth)
1176            (request-photos-for-point current-point-lonlat)
1177            (setf (@ *streetmap* step-back-point) previous-point)
1178            (setf (@ *streetmap* step-forward-point) next-point)
1179            (chain *streetmap* aux-data-linestring-layer (remove-all-features))
1180            (chain *streetmap*
1181                   aux-data-linestring-layer
1182                   (add-features linestring))))
1183
1184        (defun step (&optional back-p)
1185          "Enable walk-mode if necessary, and do a step along
1186          aux-data-linestring."
1187          (if (checkbox-status-with-id "walk-p")
1188              (let ((next-point-geometry
1189                     (if back-p
1190                         (progn
1191                           (if (< (- (@ *streetmap* linestring-central-azimuth) pi) 0)
1192                               (setf (@ *streetmap* linestring-central-azimuth)
1193                                     (+ (@ *streetmap* linestring-central-azimuth) pi))
1194                               (setf (@ *streetmap* linestring-central-azimuth)
1195                                     (- (@ *streetmap* linestring-central-azimuth) pi)))
1196                           (chain *streetmap*
1197                                  step-back-point
1198                                  (clone)
1199                                  geometry
1200                                  (transform +spherical-mercator+ +geographic+)))
1201                         (chain *streetmap*
1202                                step-forward-point
1203                                (clone)
1204                                geometry
1205                                (transform +spherical-mercator+ +geographic+)))))
1206                (request-aux-data-linestring (@ next-point-geometry x)
1207                                             (@ next-point-geometry y)
1208                                             (* *linestring-step-ratio*
1209                                                (step-size-degrees))
1210                                             (step-size-degrees)))
1211              (progn
1212                (setf (checkbox-status-with-id "walk-p") t) ;doesn't seem to trigger event
1213                (flip-walk-mode))))    ; so we have to do it explicitly
1214
1215        (defun step-size-degrees ()
1216          "Return inner-html of element step-size (metres) converted
1217          into map units (degrees).  You should be close to the
1218          equator."
1219          (/ (inner-html-with-id "step-size") 1855.325 60))
1220
1221        (defun decrease-step-size ()
1222          (when (> (inner-html-with-id "step-size") 0.5)
1223            (setf (inner-html-with-id "step-size")
1224                  (/ (inner-html-with-id "step-size") 2))))
1225
1226        (defun increase-step-size ()
1227          (when (< (inner-html-with-id "step-size") 100)
1228            (setf (inner-html-with-id "step-size")
1229                  (* (inner-html-with-id "step-size") 2))))
1230
1231        (defun user-point-style-map (label-property)
1232          "Create a style map where styles dispatch on feature property
1233          \"attribute\" and features are labelled after feature
1234          property label-property."
1235          (let* ((symbolizer-property "attribute")
1236                 (solitary-filter
1237                  (new (chain *open-layers
1238                              *filter
1239                              (*comparison (create type (chain *open-layers
1240                                                               *filter
1241                                                               *comparison
1242                                                               *like*)
1243                                                   property symbolizer-property
1244                                                   value "solitary")))))
1245                 (polyline-filter
1246                  (new (chain *open-layers
1247                              *filter
1248                              (*comparison (create type (chain *open-layers
1249                                                               *filter
1250                                                               *comparison
1251                                                               *like*)
1252                                                   property symbolizer-property
1253                                                   value "polyline")))))
1254                 (polygon-filter
1255                  (new (chain *open-layers
1256                              *filter
1257                              (*comparison (create type (chain *open-layers
1258                                                               *filter
1259                                                               *comparison
1260                                                               *like*)
1261                                                   property symbolizer-property
1262                                                   value "polygon")))))
1263                 (solitary-rule
1264                  (new (chain *open-layers
1265                              (*rule (create
1266                                      filter solitary-filter
1267                                      symbolizer (create
1268                                                  graphic-name "triangle"))))))
1269                 (polyline-rule
1270                  (new (chain *open-layers
1271                              (*rule (create
1272                                      filter polyline-filter
1273                                      symbolizer (create
1274                                                  graphic-name "square"
1275                                                  point-radius 4))))))
1276                 (polygon-rule
1277                  (new (chain *open-layers
1278                              (*rule (create
1279                                      filter polygon-filter
1280                                      symbolizer (create
1281                                                  graphic-name "star"))))))
1282                 (else-rule
1283                  (new (chain *open-layers
1284                              (*rule (create
1285                                      else-filter t
1286                                      symbolizer (create
1287                                                  graphic-name "x"))))))
1288                 (user-point-default-style
1289                  (new (chain
1290                        *open-layers
1291                        (*style (create stroke-color "OrangeRed"
1292                                        fill-color "OrangeRed"
1293                                        label-align "cb"
1294                                        label-y-offset 5
1295                                        font-color "OrangeRed"
1296                                        font-family "'andale mono', 'lucida console', monospace"
1297                                        stroke-opacity .5
1298                                        stroke-width 2
1299                                        point-radius 5
1300                                        fill-opacity 0)
1301                                (create rules (array solitary-rule
1302                                                     polyline-rule
1303                                                     polygon-rule
1304                                                     else-rule))))))
1305                 (user-point-select-style
1306                  (new (chain
1307                        *open-layers
1308                        (*style (create stroke-opacity 1
1309                                        label label-property)
1310                                (create rules (array solitary-rule
1311                                                     polyline-rule
1312                                                     polygon-rule
1313                                                     else-rule))))))
1314                 (user-point-temporary-style
1315                  (new (chain
1316                        *open-layers
1317                        (*style (create fill-opacity .5)
1318                                (create rules (array solitary-rule
1319                                                     polyline-rule
1320                                                     polygon-rule
1321                                                     else-rule)))))))
1322            (new (chain *open-layers
1323                        (*style-map
1324                         (create "default" user-point-default-style
1325                                 "temporary" user-point-temporary-style
1326                                 "select" user-point-select-style))))))
1327
1328        (defun draw-user-points ()
1329          "Draw currently selected user points into all images."
1330          (let* ((user-point-positions-response
1331                  (chain *json-parser*
1332                         (read
1333                          (@ *user-point-in-images-response* response-text))))
1334                 (user-point-collections
1335                  (chain user-point-positions-response image-points))
1336                 (user-point-count
1337                  (chain user-point-positions-response user-point-count))
1338                 (label
1339                  (when (> user-point-count 1) "${numericDescription}")))
1340            (loop
1341               for i in *images*
1342               for user-point-collection in user-point-collections
1343               do
1344               (when i    ;otherwise a photogrammetry error has occured
1345                 (let ((features
1346                        (loop
1347                           for raw-feature in
1348                           (@ user-point-collection features)
1349                           collect
1350                           (let* ((x
1351                                   (@ raw-feature geometry coordinates 0))
1352                                  (y
1353                                   (@ raw-feature geometry coordinates 1))
1354                                  (point
1355                                   (new (chain *open-layers
1356                                               *geometry
1357                                               (*point x y))))
1358                                  (fid
1359                                   (@ raw-feature id))
1360                                  (attributes
1361                                   (@ raw-feature properties))
1362                                  (feature
1363                                   (new (chain *open-layers
1364                                               *feature
1365                                               (*vector point attributes)))))
1366                             (setf (@ feature fid) fid)
1367                             (setf (@ feature render-intent) "select")
1368                             feature))))
1369                   (setf
1370                    (@ i user-point-layer)
1371                    (new (chain *open-layers
1372                                *layer
1373                                (*vector
1374                                 "User Point"
1375                                 (create display-in-layer-switcher nil
1376                                         style-map (user-point-style-map
1377                                                    label))))))
1378                   (chain i map (add-layer (@ i user-point-layer)))
1379                   (chain i user-point-layer (add-features features)))))))
1380
1381        (defun finish-point (database-writer)
1382          "Try, with some user interaction, to uniquify user-point
1383           attributes and call database-writer."
1384          (let* ((point-data
1385                  (create user-point-id (if (defined *current-user-point*)
1386                                            (@ *current-user-point* fid)
1387                                            nil)
1388                          attribute
1389                          (value-with-id "point-attribute-input")
1390                          description
1391                          (value-with-id "point-description-input")
1392                          numeric-description
1393                          (value-with-id "point-numeric-description")))
1394                 (content
1395                  (chain *json-parser*
1396                         (write point-data)))
1397                 (delete-point-button-active-p
1398                  (disable-element-with-id "delete-point-button")))
1399            (disable-element-with-id "finish-point-button")
1400            (setf *uniquify-point-attributes-response* nil)
1401            (setf *uniquify-point-attributes-response*
1402                  (chain
1403                   *open-layers
1404                   *Request
1405                   (*POST*
1406                    (create
1407                     :url (+ "/" +proxy-root+ "/lib/uniquify-point-attributes")
1408                     :data content
1409                     :headers (create "Content-type" "text/plain"
1410                                      "Content-length" (@ content
1411                                                          length))
1412                     :success
1413                     (lambda ()
1414                       (enable-element-with-id "finish-point-button")
1415                       (when delete-point-button-active-p
1416                         (enable-element-with-id "delete-point-button"))
1417                       (let ((response
1418                              (chain
1419                               *json-parser*
1420                               (read
1421                                (@ *uniquify-point-attributes-response*
1422                                   response-text)))))
1423                         (if (equal null response)
1424                             (database-writer)
1425                             (progn
1426                               (setf
1427                                (chain document
1428                                       (get-element-by-id
1429                                        "force-duplicate-button")
1430                                       onclick)
1431                                (lambda ()
1432                                  (hide-element-with-id "uniquify-buttons")
1433                                  (reveal-element-with-id "finish-point-button")
1434                                  (database-writer)))
1435                               (hide-element-with-id "finish-point-button")
1436                               (reveal-element-with-id "uniquify-buttons")))))
1437                     :failure recommend-fresh-login))))))
1438
1439        (defun insert-unique-suggestion ()
1440          "Insert previously received set of unique user-point
1441          attributes into their respective input elements; switch
1442          buttons accordingly."
1443          (let* ((point-data
1444                  (create user-point-id (if (defined *current-user-point*)
1445                                            (@ *current-user-point* fid)
1446                                            nil)
1447                          attribute
1448                          (value-with-id "point-attribute-input")
1449                          description
1450                          (value-with-id "point-description-input")
1451                          numeric-description
1452                          (value-with-id "point-numeric-description")))
1453                 (content
1454                  (chain *json-parser*
1455                         (write point-data)))
1456                 (delete-point-button-active-p
1457                  (disable-element-with-id "delete-point-button")))
1458            (disable-element-with-id "finish-point-button")
1459            (hide-element-with-id "uniquify-buttons")
1460            (reveal-element-with-id "finish-point-button")
1461            (setf *uniquify-point-attributes-response* nil)
1462            (setf *uniquify-point-attributes-response*
1463                  (chain
1464                   *open-layers
1465                   *Request
1466                   (*POST*
1467                    (create :url (+ "/"
1468                                    +proxy-root+
1469                                    "/lib/uniquify-point-attributes")
1470                            :data content
1471                            :headers (create "Content-type" "text/plain"
1472                                             "Content-length" (@ content
1473                                                                 length))
1474                            :success
1475                            (lambda ()
1476                              (enable-element-with-id "finish-point-button")
1477                              (when delete-point-button-active-p
1478                                (enable-element-with-id "delete-point-button"))
1479                              (let ((response
1480                                     (chain
1481                                      *json-parser*
1482                                      (read
1483                                       (@ *uniquify-point-attributes-response*
1484                                          response-text)))))
1485                                (unless (equal null response)
1486                                  (setf (value-with-id
1487                                         "point-numeric-description")
1488                                        (@ response numeric-description)))))
1489                            :failure recommend-fresh-login))))))
1490
1491        (defun store-point ()
1492          "Send freshly created user point to the database."
1493          (let ((global-position-etc *global-position*))
1494            (setf (@ global-position-etc attribute)
1495                  (value-with-id "point-attribute-input"))
1496            (setf (@ global-position-etc description)
1497                  (value-with-id "point-description-input"))
1498            (setf (@ global-position-etc numeric-description)
1499                  (value-with-id "point-numeric-description"))
1500            (when (checkbox-status-with-id "include-aux-data-p")
1501              (setf (@ global-position-etc aux-numeric)
1502                    (@ *current-nearest-aux-point*
1503                       attributes
1504                       aux-numeric))
1505              (setf (@ global-position-etc aux-text)
1506                    (@ *current-nearest-aux-point*
1507                       attributes
1508                       aux-text)))
1509            (let ((content
1510                   (chain *json-parser*
1511                          (write global-position-etc))))
1512              (disable-element-with-id "finish-point-button")
1513              (chain
1514               *open-layers
1515               *Request
1516               (*POST*
1517                (create :url (+ "/" +proxy-root+ "/lib/store-point")
1518                        :data content
1519                        :headers (create "Content-type" "text/plain"
1520                                         "Content-length" (@ content length))
1521                        :success (lambda ()
1522                                   (refresh-layer
1523                                    (@ *streetmap* user-point-layer))
1524                                   (reset-layers-and-controls)
1525                                   (request-user-point-choice))
1526                        :failure recommend-fresh-login))))))
1527
1528        (defun update-point ()
1529          "Send changes to currently selected user point to database."
1530          (let* ((point-data
1531                  (create user-point-id (@ *current-user-point* fid)
1532                          attribute
1533                          (value-with-id "point-attribute-input")
1534                          description
1535                          (value-with-id "point-description-input")
1536                          numeric-description
1537                          (value-with-id "point-numeric-description")))
1538                 (content
1539                  (chain *json-parser*
1540                         (write point-data))))
1541            (disable-element-with-id "finish-point-button")
1542            (disable-element-with-id "delete-point-button")
1543            (chain *open-layers
1544                   *Request
1545                   (*POST*
1546                    (create :url (+ "/" +proxy-root+ "/lib/update-point")
1547                            :data content
1548                            :headers (create "Content-type" "text/plain"
1549                                             "Content-length" (@ content
1550                                                                 length))
1551                            :success (lambda ()
1552                                       (refresh-layer
1553                                        (@ *streetmap* user-point-layer))
1554                                       (reset-layers-and-controls)
1555                                       (request-user-point-choice))
1556                            :failure recommend-fresh-login)))))
1557
1558        (defun delete-point ()
1559          "Purge currently selected user point from database."
1560          (let* ((user-point-id (@ *current-user-point* fid))
1561                 (content
1562                  (chain *json-parser*
1563                         (write user-point-id))))
1564            (disable-element-with-id "finish-point-button")
1565            (disable-element-with-id "delete-point-button")
1566            (chain *open-layers
1567                   *Request
1568                   (*POST*
1569                    (create :url (+ "/" +proxy-root+ "/lib/delete-point")
1570                            :data content
1571                            :headers (create "Content-type" "text/plain"
1572                                             "Content-length" (@ content
1573                                                                 length))
1574                            :success (lambda ()
1575                                       (refresh-layer
1576                                        (@ *streetmap* user-point-layer))
1577                                       (reset-layers-and-controls)
1578                                       (request-user-point-choice true))
1579                            :failure recommend-fresh-login)))))
1580
1581        (defun draw-active-point ()
1582          "Draw an Active Point, i.e. a point used in subsequent
1583          photogrammetric calculations."
1584          (chain this
1585                 active-point-layer
1586                 (add-features
1587                  (new (chain *open-layers
1588                              *feature
1589                              (*vector
1590                               (new (chain *open-layers
1591                                           *geometry
1592                                           (*point
1593                                            (@ this photo-parameters m)
1594                                            (@ this photo-parameters n))))))))))
1595
1596        (defun image-click-action (clicked-image)
1597          (lambda (event)
1598            "Do appropriate things when an image is clicked into."
1599            (let* ((lonlat
1600                    (chain clicked-image map (get-lon-lat-from-view-port-px
1601                                              (@ event xy))))
1602                   (photo-parameters
1603                    (@ clicked-image photo-parameters))
1604                   pristine-image-p content request)
1605              (when (and (@ photo-parameters usable)
1606                         (chain clicked-image (photop)))
1607                (setf (@ photo-parameters m) (@ lonlat lon)
1608                      (@ photo-parameters n) (@ lonlat lat))
1609                (remove-layer (@ clicked-image map) "Active Point")
1610                (remove-any-layers "Epipolar Line")
1611                (setf *pristine-images-p* (not (some-active-point-p)))
1612                (setf (@ clicked-image active-point-layer)
1613                      (new (chain *open-layers
1614                                  *layer
1615                                  (*vector "Active Point"
1616                                           (create display-in-layer-switcher
1617                                                   nil)))))
1618                (chain clicked-image
1619                       map
1620                       (add-layer (@ clicked-image active-point-layer)))
1621                (chain clicked-image (draw-active-point))
1622                (if
1623                 *pristine-images-p*
1624                 (progn
1625                   (chain *streetmap* user-points-select-control (unselect-all))
1626                   (reset-controls)
1627                   ;; (setf (value-with-id "point-numeric-description")
1628                   ;;       (increment-numeric-text
1629                   ;;        (value-with-id "point-numeric-description")))
1630                   (remove-any-layers "User Point") ;from images
1631                   (loop
1632                      for i across *images* do
1633                      (when (and (not (equal i clicked-image))
1634                                 (chain i (photop)))
1635                        (setf
1636                         (@ i epipolar-layer)
1637                         (new (chain *open-layers
1638                                     *layer
1639                                     (*vector "Epipolar Line"
1640                                              (create
1641                                               display-in-layer-switcher nil))))
1642                         content (chain *json-parser*
1643                                        (write
1644                                         (append (array photo-parameters)
1645                                                 (@ i photo-parameters))))
1646                         (@ i epipolar-request-response)
1647                         (chain *open-layers
1648                                *Request
1649                                (*POST*
1650                                 (create :url (+ "/" +proxy-root+
1651                                                 "/lib/epipolar-line")
1652                                         :data content
1653                                         :headers (create
1654                                                   "Content-type" "text/plain"
1655                                                   "Content-length"
1656                                                   (@ content length))
1657                                         :success (@ i draw-epipolar-line)
1658                                         :failure recommend-fresh-login
1659                                         :scope i))))
1660                        (chain i
1661                               map
1662                               (add-layer (@ i epipolar-layer))))))
1663                 (progn
1664                   (remove-any-layers "Epipolar Line")
1665                   (remove-any-layers "Estimated Position")
1666                   (let* ((active-pointed-photo-parameters
1667                           (loop
1668                              for i across *images*
1669                              when (has-layer-p (@ i map) "Active Point")
1670                              collect (@ i photo-parameters)))
1671                          (content
1672                           (chain *json-parser*
1673                                  (write
1674                                   (list active-pointed-photo-parameters
1675                                         (chain *images*
1676                                                (map
1677                                                 #'(lambda (x)
1678                                                     (@ x
1679                                                        photo-parameters)))))))))
1680                     (setf (@ clicked-image estimated-positions-request-response)
1681                           (chain *open-layers
1682                                  *Request
1683                                  (*POST*
1684                                   (create :url (+ "/" +proxy-root+
1685                                                   "/lib/estimated-positions")
1686                                           :data content
1687                                           :headers (create
1688                                                     "Content-type" "text/plain"
1689                                                     "Content-length"
1690                                                     (@ content length))
1691                                           :success (@ clicked-image
1692                                                       draw-estimated-positions)
1693                                           :failure recommend-fresh-login
1694                                           :scope clicked-image)))))))))))
1695
1696        (defun iso-time-string (lisp-time)
1697          "Return Lisp universal time formatted as ISO time string"
1698          (let* ((unix-time (- lisp-time +unix-epoch+))
1699                 (js-date (new (*date (* 1000 unix-time)))))
1700            (chain *open-layers *date (to-i-s-o-string js-date))))
1701
1702        (defun delete-photo ()
1703          "Delete this object's photo."
1704          (loop
1705             repeat (chain this map (get-num-layers))
1706             do (chain this map layers 0 (destroy)))
1707          (hide-element-with-id (@ this usable-id))
1708          (setf (@ this trigger-time-div inner-h-t-m-l) nil))
1709
1710        (defun photop ()
1711          "Check if this object contains a photo."
1712          (@ this trigger-time-div inner-h-t-m-l))
1713
1714        (defun show-photo ()
1715          "Show the photo described in this object's photo-parameters."
1716          (let ((image-div-width
1717                 (parse-int (chain (get-computed-style (@ this map div) nil)
1718                                   width)))
1719                (image-div-height
1720                 (parse-int (chain (get-computed-style (@ this map div) nil)
1721                                   height)))
1722                (image-width
1723                 (@ this photo-parameters sensor-width-pix))
1724                (image-height
1725                 (@ this photo-parameters sensor-height-pix)))
1726            (chain
1727             this
1728             map
1729             (add-layer
1730              (new (chain
1731                    *open-layers
1732                    *layer
1733                    (*image
1734                     "Photo"
1735                     (photo-path (@ this photo-parameters))
1736                     (new (chain *open-layers
1737                                 (*bounds
1738                                  -.5 -.5
1739                                  (+ image-width .5) (+ image-height .5))))
1740                     (new (chain *open-layers
1741                                 (*size image-div-width
1742                                        image-div-height)))
1743                     (create
1744                      max-resolution (chain
1745                                      *math
1746                                      (max
1747                                       (/ image-width image-div-width)
1748                                       (/ image-height image-div-height)))))))))
1749            (when (@ this photo-parameters rendered-footprint)
1750              (setf (@ this footprint-layer)
1751                    (new (chain
1752                          *open-layers
1753                          *layer
1754                          (*vector "Footprint"
1755                                   (create display-in-layer-switcher nil
1756                                           style (create stroke-color "yellow"
1757                                                         stroke-width 1
1758                                                         stroke-opacity .3))))))
1759              (chain this
1760                     footprint-layer
1761                     (add-features
1762                      (chain *geojson-parser*
1763                             (read (@ this
1764                                      photo-parameters
1765                                      rendered-footprint)))))
1766              (chain this
1767                     map
1768                     (add-layer (@ this footprint-layer))))
1769            (chain this map (zoom-to-max-extent))
1770            (if (@ this photo-parameters usable)
1771                (hide-element-with-id (@ this usable-id))
1772                (reveal-element-with-id (@ this usable-id)))
1773            (setf (@ this trigger-time-div inner-h-t-m-l)
1774                  (iso-time-string (@ this photo-parameters trigger-time)))))
1775
1776        (defun zoom-images-to-max-extent ()
1777          "Zoom out all images."
1778          (loop for i across *images* do (chain i map (zoom-to-max-extent))))
1779
1780        (defun zoom-anything-to-point ()
1781          "For streetmap and for images that have an Active Point or an
1782          Estimated Position, zoom in and recenter."
1783          (when (checkbox-status-with-id "zoom-to-point-p")
1784            (let ((point-lonlat
1785                   (new (chain *open-layers
1786                               (*lon-lat (@ *global-position* longitude)
1787                                         (@ *global-position* latitude))
1788                               (transform +geographic+ +spherical-mercator+)))))
1789              (when point-lonlat
1790                (chain *streetmap*
1791                       (set-center point-lonlat 18 nil t))))
1792            (loop for i across *images* do
1793                 (let ((point-lonlat
1794                        (cond
1795                          ((has-layer-p (@ i map) "Active Point")
1796                           (new (chain *open-layers (*lon-lat
1797                                                     (@ i photo-parameters m)
1798                                                     (@ i photo-parameters n)))))
1799                          ((has-layer-p (@ i map) "Estimated Position")
1800                           (@ i estimated-position-lonlat))
1801                          (t false))))
1802                   (when point-lonlat
1803                     (chain i map (set-center point-lonlat 4 nil t)))))))
1804
1805        (defun initialize-image (image-index)
1806          "Create an image usable for displaying photos at position
1807          image-index in array *images*."
1808          (setf (aref *images* image-index) (new *image))
1809          (setf (@ (aref *images* image-index) usable-id)
1810                (+ "image-" image-index "-usable"))
1811          (hide-element-with-id (+ "image-" image-index "-usable"))
1812          (setf (@ (aref *images* image-index) trigger-time-div)
1813                (chain
1814                 document
1815                 (get-element-by-id (+ "image-" image-index "-trigger-time"))))
1816          (setf (@ (aref *images* image-index) image-click-action)
1817                (image-click-action (aref *images* image-index)))
1818          (setf (@ (aref *images* image-index) click)
1819                (new (*click-control*
1820                      (create :trigger (@ (aref *images* image-index)
1821                                          image-click-action)))))
1822          (chain (aref *images* image-index)
1823                 map
1824                 (add-control
1825                  (@ (aref *images* image-index) click)))
1826          (chain (aref *images* image-index) click (activate))
1827          ;;(chain (aref *images* image-index)
1828          ;;       map
1829          ;;       (add-control
1830          ;;        (new (chain *open-layers
1831          ;;                    *control
1832          ;;                    (*mouse-position
1833          ;;                     (create
1834          ;;                      div (chain
1835          ;;                           document
1836          ;;                           (get-element-by-id
1837          ;;                            (+ "image-" image-index "-zoom")))))))))
1838          (chain (aref *images* image-index)
1839                 map
1840                 (add-control
1841                  (new (chain *open-layers
1842                              *control
1843                              (*layer-switcher
1844                               (create
1845                                div (chain
1846                                     document
1847                                     (get-element-by-id
1848                                      (+ "image-" image-index "-layer-switcher")))
1849                                rounded-corner nil))))))
1850          (let ((pan-west-control
1851                 (new (chain *open-layers *control (*pan "West"))))
1852                (pan-north-control
1853                 (new (chain *open-layers *control (*pan "North"))))
1854                (pan-south-control
1855                 (new (chain *open-layers *control (*pan "South"))))
1856                (pan-east-control
1857                 (new (chain *open-layers *control (*pan "East"))))
1858                (zoom-in-control
1859                 (new (chain *open-layers *control (*zoom-in))))
1860                (zoom-out-control
1861                 (new (chain *open-layers *control (*zoom-out))))
1862                (zoom-to-max-extent-control
1863                 (new (chain *open-layers *control (*zoom-to-max-extent))))
1864                (pan-zoom-panel
1865                 (new (chain *open-layers
1866                             *control
1867                             (*panel
1868                              (create div
1869                                      (chain
1870                                       document
1871                                       (get-element-by-id
1872                                        (+ "image-" image-index "-zoom")))))))))
1873            (chain (aref *images* image-index)
1874                   map
1875                   (add-control pan-zoom-panel))
1876            (chain pan-zoom-panel
1877                   (add-controls (array pan-west-control
1878                                        pan-north-control
1879                                        pan-south-control
1880                                        pan-east-control
1881                                        zoom-in-control
1882                                        zoom-out-control
1883                                        zoom-to-max-extent-control))))
1884          (chain (aref *images* image-index)
1885                 map
1886                 (render (chain document
1887                                (get-element-by-id
1888                                 (+ "image-" image-index))))))
1889
1890        (defun user-point-selected (event)
1891          "Things to do once a user point is selected."
1892          (remove-any-layers "Active Point")
1893          (remove-any-layers "Epipolar Line")
1894          (remove-any-layers "Estimated Position")
1895          (unselect-combobox-selection "point-attribute")
1896          (unselect-combobox-selection "point-description")
1897          (user-point-selection-changed))
1898
1899        (defun user-point-unselected (event)
1900          "Things to do once a user point is unselected."
1901          (reset-controls)
1902          (user-point-selection-changed))
1903
1904        (defun user-point-selection-changed ()
1905          "Things to do once a user point is selected or unselected."
1906          (hide-aux-data-choice)
1907          (setf *current-user-point*
1908                (@ *streetmap* user-point-layer selected-features 0))
1909          (let ((selected-features-count
1910                 (@ *streetmap* user-point-layer selected-features length)))
1911            (setf (@ *streetmap* user-point-layer style-map)
1912                  (user-point-style-map
1913                   (when (> selected-features-count 1)
1914                     "${numericDescription}")))
1915            (cond
1916              ((> selected-features-count 1)
1917               (hide-element-with-id "real-phoros-controls")
1918               (reveal-element-with-id "multiple-points-phoros-controls"))
1919              ((= selected-features-count 1)
1920               (setf (value-with-id "point-attribute-input")
1921                     (@ *current-user-point* attributes attribute))
1922               (setf (value-with-id "point-description-input")
1923                     (@ *current-user-point* attributes description))
1924               (setf (value-with-id "point-numeric-description")
1925                     (@ *current-user-point* attributes numeric-description))
1926               (setf (inner-html-with-id "point-creation-date")
1927                     (@ *current-user-point* attributes creation-date))
1928               (setf (inner-html-with-id "aux-numeric-list")
1929                     (html-table
1930                      (@ *current-user-point* attributes aux-numeric)
1931                      +aux-numeric-labels+))
1932               (setf (inner-html-with-id "aux-text-list")
1933                     (html-table
1934                      (@ *current-user-point* attributes aux-text)
1935                      +aux-text-labels+))
1936               (if (write-permission-p
1937                    (@ *current-user-point* attributes user-name))
1938                   (progn
1939                     (setf (chain document
1940                                  (get-element-by-id "finish-point-button")
1941                                  onclick)
1942                           (lambda () (finish-point #'update-point)))
1943                     (enable-element-with-id "finish-point-button")
1944                     (enable-element-with-id "delete-point-button")
1945                     (setf (inner-html-with-id "h2-controls") "Edit Point"))
1946                   (progn
1947                     (disable-element-with-id "finish-point-button")
1948                     (disable-element-with-id "delete-point-button")
1949                     (setf (inner-html-with-id "h2-controls") "View Point")))
1950               (setf (inner-html-with-id "creator")
1951                     (if (@ *current-user-point* attributes user-name)
1952                         (+ "(by "
1953                            (@ *current-user-point* attributes user-name)
1954                            ")")
1955                         "(ownerless)")))
1956              (t
1957               (hide-element-with-id "multiple-points-phoros-controls")
1958               (reveal-element-with-id "real-phoros-controls"))))
1959          (chain *streetmap* user-point-layer (redraw))
1960          (remove-any-layers "User Point") ;from images
1961          (setf content
1962                (chain *json-parser*
1963                       (write
1964                        (array (chain *streetmap*
1965                                      user-point-layer
1966                                      selected-features
1967                                      (map (lambda (x) (@ x fid))))
1968                               (loop
1969                                  for i across *images*
1970                                  collect (@ i photo-parameters))))))
1971          (setf *user-point-in-images-response*
1972                (chain *open-layers
1973                       *Request
1974                       (*POST*
1975                        (create :url (+ "/" +proxy-root+
1976                                        "/lib/user-point-positions")
1977                                :data content
1978                                :headers (create "Content-type" "text/plain"
1979                                                 "Content-length" (@ content
1980                                                                     length))
1981                                :success draw-user-points
1982                                :failure recommend-fresh-login)))))
1983
1984        (defun aux-point-distance-selected ()
1985          "Things to do on change of aux-point-distance select element."
1986          (chain *streetmap*
1987                 nearest-aux-points-select-control
1988                 (unselect-all))
1989          (chain *streetmap*
1990                 nearest-aux-points-select-control
1991                 (select
1992                  (chain
1993                   (elt (@ *streetmap* nearest-aux-points-layer features)
1994                        (@ *aux-point-distance-select*
1995                           options
1996                           selected-index))))))
1997
1998        (defun enable-aux-point-selection ()
1999          "Check checkbox include-aux-data-p and act accordingly."
2000          (setf (checkbox-status-with-id "include-aux-data-p") t)
2001          (flip-aux-data-inclusion))
2002
2003        (defun flip-walk-mode ()
2004          "Query status of checkbox walk-p and induce first walking
2005          step if it's just been turned on.  Otherwise delete our
2006          walking path."
2007          (if (checkbox-status-with-id "walk-p")
2008              (request-aux-data-linestring-for-point (@ *streetmap*
2009                                                        clicked-lonlat))
2010              (chain *streetmap*
2011                     aux-data-linestring-layer
2012                     (remove-all-features))))
2013
2014        (defun flip-aux-data-inclusion ()
2015          "Query status of checkbox include-aux-data-p and act
2016          accordingly."
2017          (if (checkbox-status-with-id "include-aux-data-p")
2018              (chain *streetmap*
2019                     nearest-aux-points-layer
2020                     (set-visibility t))
2021              (chain *streetmap*
2022                     nearest-aux-points-layer
2023                     (set-visibility nil))))
2024
2025        (defun html-table (aux-data labels)
2026          "Return an html-formatted table with a label column from
2027          labels and a data column from aux-data."
2028          (if aux-data
2029              (who-ps-html
2030               (:table :class "aux-data-table"
2031                       (chain aux-data
2032                              (reduce (lambda (x y i)
2033                                        (+ x (who-ps-html
2034                                              (:tr
2035                                               (:td :class "aux-data-label"
2036                                                    (+
2037                                                     (if labels
2038                                                         (elt labels i)
2039                                                         i)
2040                                                     ":"))
2041                                               (:td :class "aux-data-value"
2042                                                    y)))))
2043                                      ""))))
2044              ""))
2045
2046        (defun nearest-aux-point-selected (event)
2047          "Things to do once a nearest auxiliary point is selected in
2048          streetmap."
2049          (setf *current-nearest-aux-point* (@ event feature))
2050          (let ((aux-numeric
2051                 (@ event feature attributes aux-numeric))
2052                (aux-text
2053                 (@ event feature attributes aux-text))
2054                (distance
2055                 (@ event feature attributes distance)))
2056            (setf (@ *aux-point-distance-select* options selected-index)
2057                  (@ event feature fid))
2058            (setf (inner-html-with-id "aux-numeric-list")
2059                  (html-table aux-numeric +aux-numeric-labels+))
2060            (setf (inner-html-with-id "aux-text-list")
2061                  (html-table aux-text +aux-text-labels+))))
2062
2063        (defun bye ()
2064          "Store user's current map extent and log out."
2065          (let* ((bbox (chain *streetmap*
2066                              (get-extent)
2067                              (transform +spherical-mercator+ +geographic+)
2068                              (to-b-b-o-x)))
2069                 (href (+ "/" +proxy-root+ "/lib/logout?bbox=" bbox)))
2070            (when (@ *streetmap* cursor-layer features length)
2071              (let* ((lonlat-geographic (chain *streetmap*
2072                                               cursor-layer
2073                                               features
2074                                               0
2075                                               geometry
2076                                               (clone)
2077                                               (transform +spherical-mercator+
2078                                                          +geographic+))))
2079                (setf href (+ href
2080                              "&longitude=" (@ lonlat-geographic x)
2081                              "&latitude=" (@ lonlat-geographic y)))))
2082            (setf (@ location href) href)))
2083
2084        (defun init ()
2085          "Prepare user's playground."
2086          (unless +presentation-project-bbox-text+
2087            (setf (inner-html-with-id "presentation-project-emptiness")
2088                  "(no data)"))
2089          (setf *streetmap*
2090                (new (chain
2091                      *open-layers
2092                      (*map "streetmap"
2093                            (create projection +geographic+
2094                                    display-projection +geographic+
2095                                    controls (array (new (chain *open-layers
2096                                                                *control
2097                                                                (*navigation)))
2098                                                    (new (chain *open-layers
2099                                                                *control
2100                                                                (*attribution)))))))))
2101          (unless +aux-data-p+
2102            (disable-element-with-id "walk-p")
2103            (hide-element-with-id "decrease-step-size")
2104            (hide-element-with-id "step-size")
2105            (hide-element-with-id "increase-step-size")
2106            (hide-element-with-id "step-button"))
2107          (when (write-permission-p)
2108            (enable-element-with-id "point-attribute-input")
2109            (enable-element-with-id "point-attribute-select")
2110            (enable-element-with-id "point-description-input")
2111            (enable-element-with-id "point-description-select")
2112            (enable-element-with-id "point-numeric-description")
2113            (request-user-point-choice true))
2114          (setf (inner-html-with-id "h2-controls") "Create Point")
2115          (hide-element-with-id "multiple-points-phoros-controls")
2116          (hide-element-with-id "no-footprints-p")
2117          (hide-element-with-id "caching-indicator")
2118          (hide-element-with-id "uniquify-buttons")
2119          ;; (setf *point-attributes-select*
2120          ;;       (chain document (get-element-by-id "point-attribute-select")))
2121          (setf *aux-point-distance-select*
2122                (chain document (get-element-by-id "aux-point-distance")))
2123          (hide-aux-data-choice)
2124          (let ((cursor-layer-style
2125                 (create
2126                  graphic-width 14
2127                  external-graphic (+ "/" +proxy-root+
2128                                      "/lib/public_html/phoros-cursor.png"))))
2129            (setf (@ *streetmap* cursor-layer)
2130                  (new (chain
2131                        *open-layers *layer
2132                        (*vector
2133                         "you"
2134                         (create
2135                          style cursor-layer-style)))))
2136            (setf (@ *streetmap* overview-cursor-layer)
2137                  (new (chain
2138                        *open-layers *layer
2139                        (*vector
2140                         "you"
2141                         (create
2142                          style cursor-layer-style))))))
2143          (let ((survey-layer-style
2144                 (create stroke-color (chain *open-layers *feature *vector
2145                                             style "default" stroke-color)
2146                         stroke-width 1
2147                         point-radius 2
2148                         fill-opacity 0
2149                         graphic-name "circle")))
2150            (setf (@ *streetmap* survey-layer)
2151                  (new (chain
2152                        *open-layers *layer
2153                        (*vector
2154                         "survey"
2155                         (create
2156                          strategies (array (new (*bbox-strategy*)))
2157                          protocol
2158                          (new (*http-protocol*
2159                                (create :url (+ "/" +proxy-root+
2160                                                "/lib/points.json"))))
2161                          style survey-layer-style))))))
2162          (setf (@ *streetmap* user-point-layer)
2163                (new (chain
2164                      *open-layers *layer
2165                      (*vector
2166                       "user points"
2167                       (create
2168                        strategies (array (new *bbox-strategy*))
2169                        protocol
2170                        (new (*http-protocol*
2171                              (create :url (+ "/" +proxy-root+ "/lib/user-points.json"))))
2172                        style-map (user-point-style-map nil))))))
2173          (setf (@ *streetmap* user-points-hover-control)
2174                (new (chain *open-layers
2175                            *control
2176                            (*select-feature (@ *streetmap* user-point-layer)
2177                                             (create render-intent "temporary"
2178                                                     hover t
2179                                                     highlight-only t)))))
2180          (setf (@ *streetmap* user-points-select-control)
2181                (new (chain *open-layers
2182                            *control
2183                            (*select-feature (@ *streetmap* user-point-layer)
2184                                             (create toggle t
2185                                                     multiple t)))))
2186          (let ((aux-layer-style
2187                 (create stroke-color "grey"
2188                         stroke-width 1
2189                         point-radius 2
2190                         fill-opacity 0
2191                         graphic-name "circle")))
2192            (setf (@ *streetmap* aux-point-layer)
2193                  (new (chain
2194                        *open-layers *layer
2195                        (*vector
2196                         "auxiliary data"
2197                         (create
2198                          strategies (array (new (*bbox-strategy*)))
2199                          protocol
2200                          (new (*http-protocol*
2201                                (create :url (+ "/" +proxy-root+
2202                                                "/lib/aux-points.json"))))
2203                          style aux-layer-style
2204                          visibility nil))))))
2205          (let ((nearest-aux-point-layer-style-map
2206                 (new (chain *open-layers
2207                             (*style-map
2208                              (create "default"
2209                                      (create stroke-color "grey"
2210                                              stroke-width 1
2211                                              point-radius 5
2212                                              fill-opacity 0
2213                                              graphic-name "circle")
2214                                      "select"
2215                                      (create stroke-color "black"
2216                                              stroke-width 1
2217                                              point-radius 5
2218                                              fill-opacity 0
2219                                              graphic-name "circle")
2220                                      "temporary"
2221                                      (create stroke-color "grey"
2222                                              stroke-width 1
2223                                              point-radius 5
2224                                              fill-color "grey"
2225                                              fill-opacity 1
2226                                              graphic-name "circle")))))))
2227            (setf (@ *streetmap* nearest-aux-points-layer)
2228                  (new (chain *open-layers
2229                              *layer
2230                              (*vector
2231                               "Nearest Aux Points"
2232                               (create
2233                                display-in-layer-switcher nil
2234                                style-map nearest-aux-point-layer-style-map
2235                                visibility t))))))
2236          (setf (@ *streetmap* nearest-aux-points-hover-control)
2237                (new (chain *open-layers
2238                            *control
2239                            (*select-feature
2240                             (@ *streetmap* nearest-aux-points-layer)
2241                             (create render-intent "temporary"
2242                                     hover t
2243                                     highlight-only t)))))
2244          (setf (@ *streetmap* nearest-aux-points-select-control)
2245                (new (chain *open-layers
2246                            *control
2247                            (*select-feature
2248                             (@ *streetmap* nearest-aux-points-layer)))))
2249          (setf (@ *streetmap* aux-data-linestring-layer)
2250                (new (chain *open-layers
2251                            *layer
2252                            (*vector
2253                             "Aux Data Linestring"
2254                             (create
2255                              display-in-layer-switcher nil
2256                              style-map nearest-aux-point-layer-style-map
2257                              visibility t)))))
2258          (setf (@ *streetmap* google-streetmap-layer)
2259                (new (chain *open-layers
2260                            *layer
2261                            (*google "Google Streets"
2262                                     (create num-zoom-levels 23)))))
2263          (setf (@ *streetmap* osm-layer)
2264                (new (chain *open-layers
2265                            *layer
2266                            (*osm*
2267                             "OpenStreetMap"
2268                             nil
2269                             (create num-zoom-levels 23
2270                                     attribution
2271                                     "Data CC-By-SA by openstreetmap.org")))))
2272          (setf (@ *streetmap* overview-osm-layer)
2273                (new (chain *open-layers
2274                            *layer
2275                            (*osm* "OpenStreetMap"))))
2276          (setf (@ *streetmap* click-streetmap)
2277                (new (*click-control*
2278                      (create :trigger request-photos-after-click))))
2279          (setf (@ *streetmap* nirvana-layer)
2280                (new (chain
2281                      *open-layers
2282                      (*layer
2283                       "Nirvana"
2284                       (create is-base-layer t
2285                               projection (@ *streetmap* osm-layer projection)
2286                               max-extent (@ *streetmap* osm-layer max-extent)
2287                               max-resolution (@ *streetmap*
2288                                                 osm-layer
2289                                                 max-resolution)
2290                               units (@ *streetmap* osm-layer units)
2291                               num-zoom-levels (@ *streetmap*
2292                                                  osm-layer
2293                                                  num-zoom-levels))))))
2294          (chain *streetmap*
2295                 (add-control
2296                  (new (chain *open-layers
2297                              *control
2298                              (*layer-switcher
2299                               (create
2300                                div (chain
2301                                     document
2302                                     (get-element-by-id
2303                                      "streetmap-layer-switcher"))
2304                                rounded-corner nil))))))
2305          (let ((pan-west-control
2306                 (new (chain *open-layers *control (*pan "West"))))
2307                (pan-north-control
2308                 (new (chain *open-layers *control (*pan "North"))))
2309                (pan-south-control
2310                 (new (chain *open-layers *control (*pan "South"))))
2311                (pan-east-control
2312                 (new (chain *open-layers *control (*pan "East"))))
2313                (zoom-in-control
2314                 (new (chain *open-layers *control (*zoom-in))))
2315                (zoom-out-control
2316                 (new (chain *open-layers *control (*zoom-out))))
2317                (zoom-to-max-extent-control
2318                 (new (chain
2319                       *open-layers
2320                       *control
2321                       (*button
2322                        (create
2323                         display-class "streetmapZoomToMaxExtent"
2324                         trigger (lambda ()
2325                                   (chain *streetmap*
2326                                          (zoom-to-extent
2327                                           +presentation-project-bounds+ ))))))))
2328                (pan-zoom-panel
2329                 (new (chain *open-layers
2330                             *control
2331                             (*panel
2332                              (create div
2333                                      (chain
2334                                       document
2335                                       (get-element-by-id
2336                                        "streetmap-zoom")))))))
2337                (overview-map
2338                 (new (chain *open-layers
2339                             *control
2340                             (*overview-map
2341                              (create
2342
2343                               layers (array
2344                                       (@ *streetmap* overview-osm-layer)
2345                                       (@ *streetmap* overview-cursor-layer))
2346
2347                               min-ratio 14
2348                               max-ratio 16
2349                               div (chain document
2350                                          (get-element-by-id
2351                                           "streetmap-overview")))))))
2352                (mouse-position-control
2353                 (new (chain *open-layers
2354                             *control
2355                             (*mouse-position
2356                              (create div (chain document
2357                                                 (get-element-by-id
2358                                                  "streetmap-mouse-position"))
2359                                      empty-string "longitude, latitude")))))
2360                (scale-line-control
2361                 (new (chain *open-layers
2362                             *control
2363                             *scale-line))))
2364            (chain *streetmap*
2365                   (add-control pan-zoom-panel))
2366            (chain pan-zoom-panel
2367                   (add-controls (array pan-west-control
2368                                        pan-north-control
2369                                        pan-south-control
2370                                        pan-east-control
2371                                        zoom-in-control
2372                                        zoom-out-control
2373                                        zoom-to-max-extent-control)))
2374            (chain *streetmap*
2375                   (add-control (@ *streetmap* click-streetmap)))
2376            (chain *streetmap* click-streetmap (activate))
2377
2378            (chain *streetmap*
2379                   user-point-layer
2380                   events
2381                   (register "featureselected"
2382                             (@ *streetmap* user-point-layer)
2383                             user-point-selected))
2384            (chain *streetmap*
2385                   user-point-layer
2386                   events
2387                   (register "featureunselected"
2388                             (@ *streetmap* user-point-layer)
2389                             user-point-unselected))
2390            (chain *streetmap*
2391                   nearest-aux-points-layer
2392                   events
2393                   (register "featureselected"
2394                             (@ *streetmap* nearest-aux-points-layer)
2395                             nearest-aux-point-selected))
2396            (chain *streetmap*
2397                   (add-control
2398                    (@ *streetmap* nearest-aux-points-hover-control)))
2399            (chain *streetmap*
2400                   (add-control
2401                    (@ *streetmap* nearest-aux-points-select-control)))
2402            (chain *streetmap*
2403                   (add-control
2404                    (@ *streetmap* user-points-hover-control)))
2405            (chain *streetmap*
2406                   (add-control
2407                    (@ *streetmap* user-points-select-control)))
2408            (chain *streetmap* user-points-hover-control (activate))
2409            (chain *streetmap* user-points-select-control (activate))
2410            (chain *streetmap* nearest-aux-points-hover-control (activate))
2411            (chain *streetmap* nearest-aux-points-select-control (activate))
2412            (chain *streetmap* (add-layer (@ *streetmap* osm-layer)))
2413            (try (chain *streetmap*
2414                        (add-layer (@ *streetmap* google-streetmap-layer)))
2415                 (:catch (c)
2416                   (chain *streetmap*
2417                          (remove-layer (@ *streetmap*
2418                                           google-streetmap-layer)))))
2419            (chain *streetmap* (add-layer (@ *streetmap* nirvana-layer)))
2420            (chain *streetmap*
2421                   (add-layer (@ *streetmap* nearest-aux-points-layer)))
2422            (chain *streetmap* (add-layer (@ *streetmap* survey-layer)))
2423            (chain *streetmap*
2424                   (add-layer (@ *streetmap* cursor-layer)))
2425            (chain *streetmap*
2426                   (add-layer (@ *streetmap* aux-point-layer)))
2427            (chain *streetmap*
2428                   (add-layer (@ *streetmap* aux-data-linestring-layer)))
2429            (chain *streetmap*
2430                   (add-layer (@ *streetmap* user-point-layer)))
2431            (setf (@ overview-map element)
2432                  (chain document (get-element-by-id
2433                                   "streetmap-overview-element")))
2434            (chain *streetmap* (add-control overview-map))
2435            (chain *streetmap* (add-control mouse-position-control))
2436            (chain *streetmap* (add-control scale-line-control)))
2437          (loop
2438             for i from 0 below (lisp *number-of-images*)
2439             do (initialize-image i))
2440          (add-help-events)
2441          (chain *streetmap*
2442                 (zoom-to-extent
2443                  (if (lisp (stored-bbox))
2444                      (new (chain *open-layers
2445                              *bounds
2446                              (from-string (lisp (stored-bbox)))
2447                              (transform +geographic+ +spherical-mercator+)))
2448                      +presentation-project-bounds+)))
2449            (let ((stored-cursor (lisp (stored-cursor))))
2450              (when stored-cursor
2451                (request-photos
2452                 (new (chain *open-layers
2453                             *lon-lat
2454                             (from-string stored-cursor)
2455                             (transform +geographic+
2456                                        +spherical-mercator+)))))))))))
2457
2458 (pushnew (hunchentoot:create-regex-dispatcher
2459           (format nil "/phoros/lib/phoros-~A-\\S*-\\S*\.js"
2460                   (phoros-version))
2461           'phoros.js)
2462          hunchentoot:*dispatch-table*)