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