phoros-js.lisp

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