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