phoros-js.lisp

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