db-tables.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
  19 (in-package :phoros)
  20
  21 (defun nuke-all-tables ()
  22   "Drop all tables (except PostGIS helper tables) and sequences in current database.  TODO: also drop our functions and types."
  23   (let ((user-tables (list-tables))
  24         (sequences (list-sequences))
  25         (views (list-views))
  26           (system-tables '(:spatial-ref-sys :geometry-columns)))
  27     (dolist (system-table system-tables)
  28       (setf user-tables (remove system-table user-tables)))
  29     (dolist (user-table user-tables)
  30       (execute (format nil "DROP TABLE IF EXISTS ~A CASCADE" (s-sql:to-sql-name user-table))))
  31     (dolist (sequence sequences)
  32       (execute (format nil "DROP SEQUENCE IF EXISTS ~A CASCADE" (s-sql:to-sql-name sequence))))
  33     (dolist (view views)
  34       (execute (format nil "DROP VIEW IF EXISTS ~A CASCADE" (s-sql:to-sql-name view))))))
  35
  36 ;;; Used only to add Spherical Mercator in case it's missing
  37 (defclass spatial-ref-sys ()
  38   ((srid
  39     :col-type integer
  40     :initarg :srid)
  41    (auth-name
  42     :col-type (or db-null (varchar 256))
  43     :initarg :auth-name)
  44    (auth-srid
  45     :col-type (or db-null integer)
  46     :initarg :auth-srid)
  47    (srtext
  48     :col-type (or db-null (varchar 2048))
  49     :initarg :srtext)
  50    (proj4text
  51     :col-type (or db-null (varchar 2048))
  52     :initarg :proj4text))
  53   (:metaclass dao-class)
  54   (:keys srid)
  55   (:documentation "PostGIS system table as defined in http://postgis.refractions.net/documentation/manual-1.3/ch04.html#id2571306"))
  56
  57 ;;TODO: make a spatial-ref-sys table
  58
  59 (defun add-spherical-mercator-ref ()
  60   "Tell PostGIS about Spherical Mercator if necessary."
  61   (let ((spherical-mercator
  62          (make-instance
  63           'spatial-ref-sys
  64           :srid 900913
  65           :auth-name "spatialreferencing.org"
  66           :auth-srid 900913
  67           :srtext "PROJCS[\"Popular Visualisation CRS / Mercator (deprecated)\",GEOGCS[\"Popular Visualisation CRS\",DATUM[\"Popular_Visualisation_Datum\",SPHEROID[\"Popular Visualisation Sphere\",6378137,0,AUTHORITY[\"EPSG\",\"7059\"]],TOWGS84[0,0,0,0,0,0,0],AUTHORITY[\"EPSG\",\"6055\"]],PRIMEM[\"Greenwich\",0,AUTHORITY[\"EPSG\",\"8901\"]],UNIT[\"degree\",0.01745329251994328,AUTHORITY[\"EPSG\",\"9122\"]],AUTHORITY[\"EPSG\",\"4055\"]],UNIT[\"metre\",1,AUTHORITY[\"EPSG\",\"9001\"]],PROJECTION[\"Mercator_1SP\"],PARAMETER[\"central_meridian\",0],PARAMETER[\"scale_factor\",1],PARAMETER[\"false_easting\",0],PARAMETER[\"false_northing\",0],AUTHORITY[\"EPSG\",\"3785\"],AXIS[\"X\",EAST],AXIS[\"Y\",NORTH]]"
  68           :proj4text "+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y_0=0 +units=m +k=1.0 +nadgrids=@null +no_defs")))
  69     (unless (dao-exists-p spherical-mercator)
  70       (insert-dao spherical-mercator))))
  71
  72 ;;TODO: make a geometry-columns table
  73 ;;
  74 ;;CREATE TABLE geometry_columns (
  75 ;;  f_table_catalog    VARRCHAR(256) NOT NULL,
  76 ;;  f_table_schema     VARCHAR(256) NOT NULL,
  77 ;;  f_table_nam        VARCHAR(256) NOT NULL,
  78 ;;  f_geometry_column  VARCHAR(256) NOT NULL,
  79 ;;  coord_dimension    INTEGER NOT NULL,
  80 ;;  srid               INTEGER NOT NULL,
  81 ;;  type               VARCHAR(30) NOT NULL
  82 ;;)
  83
  84 (defclass sys-user ()
  85   ((user-id
  86     :reader user-id
  87
  88     :col-type integer
  89     :col-default (:nextval 'sys-user-id-seq))
  90    (user-name
  91     :col-type text
  92     :initarg :user-name
  93     :documentation "This one is used for authentication.")
  94    (user-password
  95     :writer (setf user-password)
  96     :col-type text
  97     :initarg :user-password)
  98    (user-full-name
  99     :writer (setf user-full-name)
 100     :col-type text
 101     :initarg :user-full-name))
 102   (:metaclass dao-class)
 103   (:keys user-id)
 104   (:documentation "List of users of the presentation front end.  This is certainly not a full-fledged authentication system."))
 105
 106 (deftable sys-user
 107   (:create-sequence 'sys-user-id-seq)
 108   (!dao-def))
 109
 110 (defclass sys-acquisition-project ()
 111   ((acquisition-project-id
 112     :reader acquisition-project-id
 113     :col-type integer
 114     :col-default (:nextval 'sys-acquisition-project-id-seq))
 115    (common-table-name
 116     :col-type text
 117     :initarg :common-table-name
 118     :documentation "Name of this project's data tables sans their canonical prefixes and suffixes.  Serves as a human-readable acquisition procect identifier.  Should be one table for all projects but this seems to come with a speed penalty."))
 119   (:metaclass dao-class)
 120   (:keys acquisition-project-id)
 121   (:documentation "An acquisition project is basically a set of measurements that is stored in a common table."))
 122
 123 (deftable sys-acquisition-project
 124   (:create-sequence 'sys-acquisition-project-id-seq)
 125   (!dao-def)
 126   (:alter-table sys-acquisition-project
 127                 :add :constraint "common-table-name-unique"
 128                 :unique 'common-table-name))
 129
 130 (defclass sys-presentation-project ()
 131   ((presentation-project-id
 132     :reader presentation-project-id
 133     :col-type integer
 134     :col-default (:nextval 'sys-presentation-project-id-seq))
 135    (presentation-project-name
 136     :col-type text
 137     :initarg :presentation-project-name)
 138    (bounding-box
 139     :col-type (or db-null text)
 140     :accessor bounding-box
 141     :documentation "Extent of this presentation project."))
 142   (:metaclass dao-class)
 143   (:keys presentation-project-name))
 144
 145 (deftable sys-presentation-project
 146   (:create-sequence 'sys-presentation-project-id-seq)
 147   (!dao-def)
 148   (:alter-table sys-presentation-project
 149                 :add :constraint "presentation-project-id-unique"
 150                 :unique 'presentation-project-id))
 151
 152 (defclass sys-selectable-restriction ()
 153   ((restriction-id
 154     :col-type text
 155     :initarg :restriction-id
 156     :documentation "Short descriptive string; to be used for selection of restriction on client.")
 157    (presentation-project-id
 158     :col-type integer
 159     :initarg :presentation-project-id
 160     :documentation "Presentation Project that is allowed to use the sql-clause.")
 161    (sql-clause
 162     :col-type text
 163     :initarg :sql-clause
 164     :reader sql-clause
 165     :documentation "SQL clause suitable as an AND clause in aggregate view."))
 166   (:metaclass dao-class)
 167   (:keys presentation-project-id restriction-id)
 168   (:documentation "User-selectable SQL AND clauses usable in the WHERE clause of aggregate view."))
 169
 170 (deftable sys-selectable-restriction
 171   (!dao-def)
 172   (!foreign 'sys-presentation-project 'presentation-project-id :on-delete :cascade :on-update :cascade))
 173
 174 (defclass sys-user-role ()
 175   ((user-id
 176     :initarg :user-id
 177     :col-type integer)
 178    (presentation-project-id
 179     :initarg :presentation-project-id
 180     :col-type integer)
 181    (user-role
 182     :initarg :user-role
 183     :col-type text
 184     :documentation "One of read, write, admin.")
 185    (bounding-box
 186     :col-type (or db-null text)
 187     :accessor bounding-box
 188     :documentation "Streetmap zoom extent last time user left Phoros.")
 189    (cursor
 190     :col-type (or db-null geometry)
 191     :accessor cursor
 192     :documentation "Point; user's work coordinate in streetmap last time they left Phoros."))
 193   (:metaclass dao-class)
 194   (:keys user-id presentation-project-id))
 195
 196 (deftable sys-user-role
 197   (!dao-def)
 198   (!foreign 'sys-user 'user-id :on-delete :cascade :on-update :cascade)
 199   (!foreign 'sys-presentation-project 'presentation-project-id
 200             :on-delete :cascade :on-update :cascade))
 201
 202 (defclass sys-measurement ()
 203   ((measurement-id
 204     :reader measurement-id
 205     :col-type integer
 206     :col-default (:nextval 'sys-measurement-id-seq))
 207    (acquisition-project-id
 208     :initarg :acquisition-project-id
 209     :col-type integer)
 210    (directory
 211     :initarg :directory
 212     :col-type text
 213     :documentation
 214     "Below some universal root common to all measurements; excluding
 215 `applanix/´ `images/´ etc.
 216
 217 The entire directory structure looks like this:
 218
 219 Points
 220 ======
 221 /some/path/in/our/system/this/measurement/blah/applanix/points/xyz-event1.txt
 222 /some/path/in/our/system/this/measurement/blah/applanix/points/uvw-event2.txt
 223                                           ---- +++++++++++++++ ----+++++ ++++
 224 ^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^                               ^
 225     universal root       stored here in                                event
 226                          slot directory                                number
 227
 228 Images
 229 ======
 230 /some/path/in/our/system/this/measurement/blah/images/front77.pictures
 231 /some/path/in/our/system/this/measurement/blah/images/front78.pictures
 232                                           ---- ++++++         ++++++++
 233 ^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^             ^^^^^^^^^^^^^^^^
 234     universal root       stored here in               stored file name
 235                          slot directory
 236
 237 ++++ means constant
 238 ---- means unimportant
 239
 240 TODO: /images/ part not currently enforced.")
 241    (cartesian-system
 242     :initarg :cartesian-system
 243     :col-type text
 244     :documentation
 245     "Definition (as a Proj.4 string) of the coordinate system the recorded standard deviations are in."))
 246   (:metaclass dao-class)
 247   (:keys measurement-id)
 248   (:documentation "A measurement comprises .pictures files and one set of GPS event log files in a dedicated directory."))
 249
 250 (deftable sys-measurement
 251   (:create-sequence 'sys-measurement-id-seq)
 252   (!dao-def)
 253   (!index 'measurement-id)
 254   (!foreign 'sys-acquisition-project 'acquisition-project-id
 255             :on-delete :cascade :on-update :cascade))
 256
 257 (defclass sys-presentation ()
 258   ((presentation-project-id
 259     :initarg :presentation-project-id
 260     :col-type integer)
 261    (measurement-id
 262     :initarg :measurement-id
 263     :col-type integer))
 264   (:metaclass dao-class)
 265   (:keys presentation-project-id measurement-id)
 266   (:documentation "Tell us which measurements belong to which presentation project(s)."))
 267
 268 (deftable sys-presentation
 269   (!dao-def)
 270   (!index 'measurement-id)
 271   (!foreign 'sys-presentation-project 'presentation-project-id
 272             :on-delete :cascade :on-update :cascade)
 273   (!foreign 'sys-measurement 'measurement-id
 274             :on-delete :cascade :on-update :cascade))
 275
 276 (defclass sys-camera-hardware ()
 277   ((camera-hardware-id
 278     :reader camera-hardware-id
 279     :col-type integer
 280     :col-default (:nextval 'sys-camera-hardware-id-seq))
 281    (sensor-width-pix
 282     :col-type integer)
 283    (sensor-height-pix
 284     :col-type integer)
 285    (pix-size
 286     :col-type double-float)
 287    (channels
 288     :col-type integer)
 289    (pix-depth
 290     :col-type integer)
 291    (color-raiser
 292     :col-type float[]
 293     :documentation "Array of multipliers for red, green, blue.")
 294    (bayer-pattern
 295     :col-type integer[]
 296     :documentation "Array containing the colors of the first pixels of the first rows (actually, row, as postmodern can't handle two-dimensional arrays (and if it could, we wouldn't use them anyway)).  Each pixel is to be interpreted as a three-byte RGB value, red in the least-significant byte.")
 297    (serial-number
 298     :col-type text)
 299    (description
 300     :col-type text
 301     :description "Camera type, manufacturer, etc."))
 302   (:metaclass dao-class)
 303   (:keys camera-hardware-id))
 304
 305 (deftable sys-camera-hardware
 306   (:create-sequence 'sys-camera-hardware-id-seq)
 307   (!dao-def)
 308   (!index 'camera-hardware-id))
 309
 310 (defclass sys-lens ()
 311   ((lens-id
 312     :reader lens-id
 313     :col-type integer
 314     :col-default (:nextval 'sys-lens-id-seq))
 315    (c
 316     :col-type double-float
 317     :documentation "Focal length.  Only for human consumption.")
 318    (serial-number
 319     :col-type text)
 320    (description
 321     :col-type text
 322     :documentation "Lens type, manufacturer, etc."))
 323   (:metaclass dao-class)
 324   (:keys lens-id))
 325
 326 (deftable sys-lens
 327   (:create-sequence 'sys-lens-id-seq)
 328   (!dao-def))
 329
 330 (defclass sys-generic-device ()
 331   ((generic-device-id
 332     :reader generic-device-id
 333     :col-type integer
 334     :col-default (:nextval 'sys-generic-device-id-seq))
 335    (camera-hardware-id
 336     :initarg :camera-hardware-id
 337     :col-type (or db-null integer))
 338    (lens-id
 339     :initarg :lens-id
 340     :col-type (or db-null integer))
 341    (scanner-id
 342     :initarg :scanner-id
 343     :col-type (or db-null integer)
 344     :documentation "Scanners yet to be defined."))
 345   (:metaclass dao-class)
 346   (:keys generic-device-id)
 347   (:documentation "A row should describe either a camera with a lens, or a laser scanner."))
 348
 349 (deftable sys-generic-device
 350   (:create-sequence 'sys-generic-device-id-seq)
 351   (!dao-def)
 352   (!index 'generic-device-id)
 353   (!index 'camera-hardware-id)
 354   (!foreign 'sys-camera-hardware 'camera-hardware-id
 355             :on-delete :restrict :on-update :restrict)
 356   (!foreign 'sys-lens 'lens-id :on-delete :restrict :on-update :restrict)
 357   ;;;; Once we have a sys-scanner table:
 358   ;;(!foreign 'sys-scanner 'scanner-id :on-delete :restrict :on-update :restrict)
 359   )
 360
 361 (defclass sys-device-stage-of-life ()
 362   ((device-stage-of-life-id
 363     :reader device-stage-of-life-id
 364     :col-type integer
 365     :col-default (:nextval 'sys-device-stage-of-life-seq))
 366    (recorded-device-id
 367     :col-type text
 368     :documentation "Must be stored next to each data record.  Example: in a .pictures file, this is the value of `cam=´.")
 369    (event-number
 370     :reader event-number
 371     :col-type text
 372     :documentation "Identifier for the GPS event that triggers this device.  Must correspond to the N the GPS file name: ...eventN.txt.")
 373    (generic-device-id
 374     :col-type integer)
 375    (vehicle-name
 376     :col-type text)
 377    (casing-name
 378     :col-type text
 379     :documentation "Something like `upper rear left´ or maybe `1.2.1´")
 380    (computer-name
 381     :col-type text
 382     :documentation "Computer (or or other recording device) this device is connected to.")
 383    (computer-interface-name
 384     :col-type text
 385     :documentation "Things like `eth0´, `COM1´ etc.")
 386    (mounting-date
 387     :col-type :timestamp-with-time-zone)
 388    (unmounting-date
 389     :col-type (or db-null :timestamp-with-time-zone)
 390     :documentation "Date and time when this device was unmounted or altered in other ways that may render the current calibration invalid."))
 391   (:metaclass dao-class)
 392   (:keys device-stage-of-life-id)
 393   (:documentation "This data is to be collected on the measuring vehicle.  There must be a new record for every relevant change (including accidental ones) in device configuration."))
 394
 395 (deftable sys-device-stage-of-life
 396   (:create-sequence 'sys-device-stage-of-life-seq)
 397   (!dao-def)
 398   (!index 'device-stage-of-life-id)
 399   (!index 'recorded-device-id)
 400   (!index 'mounting-date)
 401   (!index 'unmounting-date)
 402   (!foreign 'sys-generic-device 'generic-device-id
 403             :on-delete :restrict :on-update :restrict))
 404
 405 (defclass sys-camera-calibration ()
 406   ((device-stage-of-life-id
 407     :reader device-stage-of-life-id
 408     :col-type integer
 409     :documentation "This tells us what hardware this calibration is for.")
 410    (date
 411     :reader date
 412     :col-type :timestamp-with-time-zone)
 413    (person
 414     :col-type text)
 415    (main-description
 416     :col-type text
 417     :documentation "Regarding this entire set of calibration data.  Note the special-purpose description fields inner-orientation-description, outer-orientation-description, boresight-description.")
 418    (usable
 419     :col-type boolean
 420     :documentation "If false: just display images, don't perform photogrammetric calculations.")
 421    (debug
 422     :col-type boolean
 423     :documentation "If true: not for production use; may be altered or deleted at any time.")
 424    (photogrammetry-version
 425     :col-type text
 426     :documentation "Software version used to create this data.")
 427    (mounting-angle
 428     :col-type integer
 429     :documentation "Head up = 0; right ear up = 90; left ear up = -90; head down = 180.")
 430    (inner-orientation-description
 431     :col-type text
 432     :documentation "Comments regarding inner orientation calibration.")
 433    (c
 434     :col-type double-float
 435     :documentation "Inner orientation: focal length.")
 436    (xh
 437     :col-type double-float
 438     :documentation "Inner orientation: principal point displacement.")
 439    (yh
 440     :col-type double-float
 441     :documentation "Inner orientation: principal point displacement.")
 442    (a1
 443     :col-type double-float
 444     :documentation "Inner orientation: radial distortion.")
 445    (a2
 446     :col-type double-float
 447     :documentation "Inner orientation: radial distortion.")
 448    (a3
 449     :col-type double-float
 450     :documentation "Inner orientation: radial distortion.")
 451    (b1
 452     :col-type double-float
 453     :documentation "Inner orientation: asymmetric and tangential distortion.")
 454    (b2
 455     :col-type double-float
 456     :documentation "Inner orientation: asymmetric and tangential distortion.")
 457    (c1
 458     :col-type double-float
 459     :documentation "Inner orientation: affinity and shear distortion.")
 460    (c2
 461     :col-type double-float
 462     :documentation "Inner orientation: affinity and shear distortion.")
 463    (r0
 464     :col-type double-float
 465     :documentation "Inner orientation.")
 466    (outer-orientation-description
 467     :col-type text
 468     :documentation "Comments regarding outer orientation calibration.")
 469    (dx
 470     :col-type double-float
 471     :documentation "Outer orientation; in metres.")
 472    (dy
 473     :col-type double-float
 474     :documentation "Outer orientation; in metres.")
 475    (dz
 476     :col-type double-float
 477     :documentation "Outer orientation; in metres.")
 478    (omega
 479     :col-type double-float
 480     :documentation "Outer orientation.")
 481    (phi
 482     :col-type double-float
 483     :documentation "Outer orientation.")
 484    (kappa
 485     :col-type double-float
 486     :documentation "Outer orientation.")
 487    (boresight-description
 488     :col-type text
 489     :documentation "Comments regarding boresight alignment calibration.")
 490    (b-dx
 491     :col-type double-float
 492     :documentation "Boresight alignment.")
 493    (b-dy
 494     :col-type double-float
 495     :documentation "Boresight alignment.")
 496    (b-dz
 497     :col-type double-float
 498     :documentation "Boresight alignment.")
 499    (b-ddx
 500     :col-type double-float
 501     :documentation "Boresight alignment.")
 502    (b-ddy
 503     :col-type double-float
 504     :Documentation "Boresight alignment.")
 505    (b-ddz
 506     :col-type double-float
 507     :documentation "Boresight alignment.")
 508    (b-rotx
 509     :col-type double-float
 510     :documentation "Boresight alignment.")
 511    (b-roty
 512     :col-type double-float
 513     :documentation "Boresight alignment.")
 514    (b-rotz
 515     :col-type double-float
 516     :documentation "Boresight alignment.")
 517    (b-drotx
 518     :col-type double-float
 519     :documentation "Boresight alignment.")
 520    (b-droty
 521     :col-type double-float
 522     :documentation "Boresight alignment.")
 523    (b-drotz
 524     :col-type double-float
 525     :documentation "Boresight alignment.")
 526    (nx
 527     :col-type double-float
 528     :documentation "Component of unit vector of vehicle ground plane.")
 529    (ny
 530     :col-type double-float
 531     :documentation "Component of unit vector of vehicle ground plane.")
 532    (nz
 533     :col-type double-float
 534     :documentation "Component of unit vector of vehicle ground plane.")
 535    (d
 536     :col-type double-float
 537     :documentation "Distance of vehicle ground plane."))
 538   (:metaclass dao-class)
 539   (:keys device-stage-of-life-id date)
 540   (:documentation "Camera calibration parameters."))
 541
 542 (deftable sys-camera-calibration
 543   (!dao-def)
 544   (!index 'device-stage-of-life-id)
 545   (!index 'date)
 546   (!foreign 'sys-device-stage-of-life 'device-stage-of-life-id
 547             :on-delete :restrict :on-update :restrict))
 548
 549 (defun phoros-db-major-version ()
 550   "Get the version number of the database structure we are currently
 551 connected to.  It is supposed to be equal to the :major part of
 552 phoros-version."
 553   (query
 554    (:select 'last-value :from 'sys-phoros-major-version)
 555    :single!))
 556
 557 (defun (setf phoros-db-major-version) (major-version)
 558   "Set the version number of the database structure we are currently
 559 connected to. This can only be done once per database."
 560   (execute
 561    (:create-sequence 'sys-phoros-major-version
 562                      :min-value -1
 563                      :max-value major-version
 564                      :start major-version))
 565   (phoros-db-major-version))
 566
 567 (defun assert-phoros-db-major-version ()
 568   "Check if phoros version and version of the database we are
 569 connected to match."
 570   (assert (= (phoros-db-major-version) (phoros-version :major t)) ()
 571           "Can't use a Phoros database structure of version ~D.  ~
 572            It should be version ~D.  ~
 573            Either create a new database structure using this version of ~
 574            Phoros, or use Phoros version ~2:*~D.x.x."
 575           (phoros-db-major-version) (phoros-version :major t)))
 576
 577 (defun presentation-project-id-from-name (presentation-project-name)
 578   "Get from current database the presentation-project-id associated
 579 with presentation-project-name.  Signal error if there isn't any."
 580   (let ((presentation-project (get-dao 'sys-presentation-project presentation-project-name)))
 581     (assert presentation-project ()
 582             "There is no presentation project called ~A."
 583             presentation-project-name)
 584     (presentation-project-id presentation-project)))
 585
 586 (defun create-sys-tables ()
 587   "Create in current database a set of sys-* tables, i.e. tables that
 588 are used by all projects.  The database should probably be empty."
 589   (setf (phoros-db-major-version) (phoros-version :major t))
 590   (create-table 'sys-user)
 591   (create-table 'sys-acquisition-project)
 592   (create-table 'sys-presentation-project)
 593   (create-table 'sys-selectable-restriction)
 594   (create-table 'sys-user-role)
 595   (create-table 'sys-measurement)
 596   (create-table 'sys-presentation)
 597   (create-table 'sys-camera-hardware)
 598   (create-table 'sys-lens)
 599   (create-table 'sys-generic-device)
 600   (create-table 'sys-device-stage-of-life)
 601   (create-table 'sys-camera-calibration)
 602   (create-plpgsql-helpers))
 603
 604 (defun create-plpgsql-helpers ()
 605   "Create in current database a few SQL types and functions."
 606   (execute
 607    (format nil "
 608 CREATE OR REPLACE
 609 FUNCTION bendedness
 610          (point1 GEOMETRY, point2 GEOMETRY, point3 GEOMETRY)
 611 RETURNS DOUBLE PRECISION AS $$
 612 -- Phoros version ~A
 613 BEGIN
 614   RETURN abs(st_azimuth(point2, point3) - st_azimuth(point1, point2));
 615 END;
 616 $$ LANGUAGE plpgsql;"
 617            (phoros-version)))
 618   (execute
 619    "DROP TYPE IF EXISTS point_bag;")
 620   (execute
 621    "CREATE TYPE point_bag AS (id int, coordinates GEOMETRY);"))
 622
 623 (defun !!index (table field &key (index-type :btree))
 624   (format nil "CREATE INDEX ~0@*~A_~1@*~A_index ON ~0@*~A USING ~2@*~A (~1@*~A)"
 625           (s-sql:to-sql-name table)
 626           (s-sql:to-sql-name field)
 627           (s-sql:to-sql-name index-type)))
 628
 629 (defclass point-template ()
 630   (;; We need a slot point-id which is defined in our subclasses.
 631    (random
 632     :col-type integer
 633     :initform (random (expt 2 31))
 634     :documentation "Used for quickly getting an evenly distributed sample of all points.")
 635    (measurement-id
 636     :writer (setf measurement-id)
 637     :col-type integer)
 638    (event-number
 639     :documentation "Event that triggered this record.  Taken from the GPS file name: ...eventN.txt gives an event number N.  May be a string of any length.")
 640    (gps-time
 641     :reader gps-time
 642     :documentation "UTC calculated from GPS week time.")
 643    (trigger-time
 644     :writer (setf trigger-time)
 645     :col-type double-precision
 646     :documentation "Time in seconds from 1900.  Values before 1980-01-06T00:00:00Z are considered invalid.")
 647    (roll
 648     :col-type double-precision)
 649    (pitch
 650     :col-type double-precision)
 651    (heading
 652     :col-type double-precision)
 653    (east-velocity
 654     :col-type double-precision)
 655    (north-velocity
 656     :col-type double-precision)
 657    (up-velocity
 658     :col-type double-precision)
 659    (east-sd
 660     :col-type double-precision)
 661    (north-sd
 662     :col-type double-precision)
 663    (height-sd
 664     :col-type double-precision)
 665    (roll-sd
 666     :col-type double-precision)
 667    (pitch-sd
 668     :col-type double-precision)
 669    (heading-sd
 670     :col-type double-precision)
 671    (longitude
 672     :reader longitude
 673     :documentation "Same content as in slot coordinates.")
 674    (latitude
 675     :reader latitude
 676     :documentation "Same content as in slot coordinates.")
 677    (ellipsoid-height
 678     :reader ellipsoid-height
 679     :documentation "Same content as in slot coordinates.")
 680    (coordinates
 681     :col-type (or db-null geometry)
 682     :documentation "Geographic coordinates.")
 683    (easting
 684     :reader easting
 685     :documentation "In the same coordinate system as the standard deviations.")
 686    (northing
 687     :reader northing
 688     :documentation "In the same coordinate system as the standard deviations.")
 689    (cartesian-height
 690     :reader cartesian-height
 691     :documentation "In the same coordinate system as the standard deviations."))
 692   (:metaclass dao-class)
 693   (:keys point-id)
 694   (:documentation "Information about one GPS point, originally from applanix/**/*event*.txt.  There shouldn't be any point-id without a matching one in the *-image table.  This can't be enforced on database level.  Use (delete-imageless-points acquisition-project) to maintain referential integrity."))
 695
 696 (defclass image-template ()
 697   ((measurement-id
 698     :writer (setf measurement-id)
 699     :col-type integer
 700     :documentation "A primary key.  We need to recognize images should they come in twice, perhaps with slightly changed point data.  In such a case we want the old ones superseded.")
 701    (filename
 702     :reader filename
 703     :initarg :filename
 704     :col-type text
 705     :documentation "Name without any directory components.")
 706    (byte-position
 707     :reader image-byte-position
 708     :initarg :byte-position
 709     :col-type integer
 710     :documentation "Start of image in .pictures file named by slot filename.")
 711    (point-id
 712     :accessor point-id
 713     :col-type integer)
 714    (recorded-device-id
 715     :initarg :recorded-device-id
 716     :reader recorded-device-id
 717     :col-type text
 718     :documentation "As found in .pictures file, header tag `cam=´.")
 719    (footprint
 720     :initarg :footprint
 721     :col-type (or db-null geometry)
 722     :documentation "Polygon on the ground describing the approximate area covered by this image.")
 723    (footprint-device-stage-of-life-id
 724     :initarg :footprint-device-stage-of-life-id
 725     :col-type (or db-null integer)
 726     :documentation "device-stage-of-life denoting the set of calibration data the footprint of this record has been calculated with.")
 727    (gain
 728     :initarg :gain
 729     :col-type double-precision
 730     :documentation "Camera parameter. TODO: needs a decent definition")
 731    (shutter
 732     :initarg :shutter
 733     :col-type double-precision
 734     :documentation "Camera parameter. TODO: needs a decent definition")
 735    (trigger-time
 736     :initarg :trigger-time
 737     :accessor trigger-time
 738     :documentation "Time in seconds from 1900-01-01.")
 739    (fake-trigger-time-p
 740     :accessor fake-trigger-time-p
 741     :initform nil
 742     :documentation "T if trigger-time has been reconstructed from adjacent data.")
 743    (camera-timestamp
 744     :initarg :camera-timestamp
 745     :reader camera-timestamp
 746     :documentation "Some camera clocktick count starting at an unknown origin."))
 747   (:metaclass dao-class)
 748   (:keys measurement-id filename byte-position)
 749   (:documentation "One row per image, originating from a .pictures file."))
 750
 751 (defclass user-point-template ()
 752   (;; We need a slot user-point-id which is defined in our subclasses.
 753    (user-id
 754     :initarg :user-id
 755     :col-type (or db-null ;when store-user-points is fed an unknown user-name
 756                   integer)
 757     :documentation "User who stored this point.")
 758    (kind
 759     :initarg :kind
 760     :col-type text
 761     :documentation "Class of this user point.")
 762    (description
 763     :initarg :description
 764     :col-type text
 765     :documentation "User comment regarding this point.")
 766    (numeric-description
 767     :initarg :numeric-description
 768     :col-type text
 769     :documentation "User-generated point id regarding this point.")
 770    (creation-date
 771     :col-type :timestamp-with-time-zone
 772     :documentation "Creation time of this point.")
 773    (coordinates
 774     :col-type (or db-null geometry)
 775     :documentation "Geographic coordinates.")
 776    ;; (stdx-global
 777    ;;  :initarg :stdx-global
 778    ;;  :col-type double-precision
 779    ;;  :documentation "Component of standard deviation, in metres.")
 780    ;; (stdy-global
 781    ;;  :initarg :stdy-global
 782    ;;  :col-type double-precision
 783    ;;  :documentation "Component of standard deviation, in metres.")
 784    ;; (stdz-global
 785    ;;  :initarg :stdz-global
 786    ;;  :col-type double-precision
 787    ;;  :documentation "Component of standard deviation, in metres.")
 788    (input-size
 789     :initarg :input-size
 790     :col-type integer
 791     :documentation "Number of points (from different images) used for calculation.")
 792    (aux-numeric
 793     :col-type (or db-null numeric[])
 794     :documentation "Arbitrary numeric values from auxiliary point table.")
 795    (aux-text
 796     :col-type (or db-null text[])
 797     :documentation "Arbitrary text values from auxiliary point table."))
 798   (:metaclass dao-class)
 799   (:keys user-point-id)
 800   (:documentation "Points defined by users."))
 801
 802 (defclass point-data (point-template)
 803   ((point-id
 804     :accessor point-id
 805     :initform nil
 806     :col-type integer
 807     :col-default nil)                   ;to be redefined
 808    point-id-sequence-name)              ;to be redefined
 809   (:metaclass dao-class)
 810   (:table-name nil))                    ;to be redefined
 811
 812 (defclass image-data (image-template)
 813   ()
 814   (:metaclass dao-class)
 815   (:table-name nil))                    ;to be redefined
 816
 817 (defclass user-point-data (user-point-template)
 818   ((user-point-id
 819     :accessor user-point-id
 820     :initform nil
 821     :col-type integer
 822     :col-default nil)                   ;to be redefined
 823    user-point-id-sequence-name)         ;to be redefined)
 824   (:metaclass dao-class)
 825   (:table-name nil))                    ;to be redefined
 826
 827 (let ((table-prefix "dat-"))
 828   (defun point-data-table-name (common-table-name)
 829     (make-symbol (format nil "~A~A-point"
 830                          table-prefix common-table-name)))
 831
 832   (defun image-data-table-name (common-table-name)
 833     (make-symbol (format nil "~A~A-image"
 834                          table-prefix common-table-name)))
 835
 836   (defun point-id-seq-name (common-table-name)
 837     (make-symbol (format nil "~A~A-point-id-seq"
 838                          table-prefix common-table-name)))
 839
 840   (defun aggregate-view-name (common-table-name)
 841     (make-symbol (format nil "~A~A-aggregate"
 842                          table-prefix common-table-name)))
 843
 844   (defun aggregate-view-update-rule-name (common-table-name)
 845     (make-symbol (format nil "~A~A-aggregate-update"
 846                          table-prefix common-table-name))))
 847
 848 (let ((table-prefix "usr-"))
 849   (defun user-point-table-name (presentation-project-name)
 850     (make-symbol (format nil "~A~A-point"
 851                          table-prefix presentation-project-name)))
 852
 853   (defun user-point-id-seq-name (presentation-project-name)
 854     (make-symbol (format nil "~A~A-point-id-seq"
 855                          table-prefix presentation-project-name)))
 856
 857   (defun user-line-table-name (presentation-project-name)
 858     (make-symbol (format nil "~A~A-line"
 859                          table-prefix presentation-project-name))))
 860
 861 (let ((table-prefix "phoros-"))
 862   ;; This stuff may reside in a foreign database so we show explicitly
 863   ;; what it belongs to.
 864   (defun aux-point-view-name (presentation-project-name)
 865     (make-symbol (format nil "~A~A-aux-point"
 866                          table-prefix presentation-project-name)))
 867
 868   (defun thread-aux-points-function-name (presentation-project-name)
 869     (make-symbol (format nil "~A~A-thread-aux-points"
 870                           table-prefix presentation-project-name))))
 871
 872 (defun create-data-table-definitions (common-table-name)
 873   "Define or redefine a bunch of dao-classes which can hold measuring
 874 data and which are connected to database tables named
 875 common-table-name plus type-specific prefix and suffix."
 876   (let ((image-data-table-name
 877          (image-data-table-name common-table-name))
 878         (point-data-table-name
 879          (point-data-table-name common-table-name))
 880         (point-id-sequence-name
 881          (point-id-seq-name common-table-name)))
 882     (eval
 883      `(defclass point-data (point-template)
 884         ((point-id
 885           :accessor point-id
 886           :initform nil
 887           :col-type integer
 888           :col-default (:nextval ,point-id-sequence-name)) ; redefinition
 889          (point-id-sequence-name
 890           :initform ,(string point-id-sequence-name) ; redefinition
 891           :reader point-id-sequence-name
 892           :allocation :class))
 893         (:metaclass dao-class)
 894         (:table-name ,point-data-table-name))) ;redefinition
 895     (deftable point-data
 896       (:create-sequence point-id-sequence-name)
 897       (!dao-def)
 898       (!!index point-data-table-name 'random)
 899       (!!index point-data-table-name 'measurement-id)
 900       (!!index point-data-table-name 'trigger-time)
 901       (!!index point-data-table-name 'coordinates :index-type :gist)
 902       (!!index point-data-table-name 'point-id)
 903       ;; The following let shouldn't be necessary. (Wart In !foreign.)
 904       (let ((*table-symbol* point-data-table-name)
 905             (*table-name*  (s-sql:to-sql-name point-data-table-name)))
 906         (!foreign 'sys-measurement 'measurement-id
 907                   :on-delete :cascade :on-update :cascade)))
 908     (eval
 909      `(defclass image-data (image-template)
 910         ()
 911         (:metaclass dao-class)
 912         (:table-name ,image-data-table-name))) ; redefintion
 913     (deftable image-data
 914       (!dao-def)
 915       (!!index image-data-table-name 'measurement-id)
 916       (!!index image-data-table-name 'recorded-device-id)
 917       (!!index image-data-table-name 'point-id)
 918       ;; (!!index image-data-table-name 'gain)
 919       ;; (!!index image-data-table-name 'shutter)
 920       (!!index image-data-table-name 'footprint :index-type :gist)
 921       ;; The following let shouldn't be necessary. (Wart in !foreign.)
 922       (let ((*table-symbol* image-data-table-name)
 923             (*table-name*  (s-sql:to-sql-name image-data-table-name)))
 924         (!foreign point-data-table-name 'point-id
 925                   :on-delete :cascade :on-update :cascade)
 926         (!foreign 'sys-measurement 'measurement-id
 927                   :on-delete :cascade :on-update :cascade)))))
 928
 929 (defun create-user-table-definition (presentation-project-name)
 930   "Define or redefine a dao-class which can hold user points and which
 931 is connected to a database table named presentation-project-name plus
 932 type-specific prefix and suffix."
 933   (let ((user-point-table-name
 934          (user-point-table-name presentation-project-name))
 935         (user-point-id-sequence-name
 936          (user-point-id-seq-name presentation-project-name)))
 937     (eval
 938      `(defclass user-point (user-point-template)
 939         ((user-point-id
 940           :accessor point-id
 941           :initform nil
 942           :col-type integer
 943           :col-default (:nextval ,user-point-id-sequence-name))) ; redefinition
 944         (:metaclass dao-class)
 945         (:table-name ,user-point-table-name))) ;redefinition
 946     (deftable user-point
 947       (:create-sequence user-point-id-sequence-name)
 948       (!dao-def)
 949       (!!index user-point-table-name 'coordinates :index-type :gist))))
 950
 951 (defun create-aggregate-view (common-table-name)
 952   "Create a view of a set of measuring and calibration data
 953 belonging to images."
 954   (let ((image-data-table-name (image-data-table-name common-table-name))
 955         (point-data-table-name (point-data-table-name common-table-name))
 956         (aggregate-view-name (aggregate-view-name common-table-name))
 957         (aggregate-view-update-rule-name (aggregate-view-update-rule-name
 958                                           common-table-name)))
 959     (eval
 960      `(execute
 961        (:create-view
 962         ,aggregate-view-name
 963         (:select
 964          'sys-device-stage-of-life.recorded-device-id      ;debug
 965          'sys-device-stage-of-life.device-stage-of-life-id ;debug
 966          'sys-device-stage-of-life.generic-device-id       ;debug
 967          'random
 968          'presentation-project-id
 969          'directory
 970          (:dot ',image-data-table-name 'measurement-id)
 971          'filename 'byte-position
 972          (:dot ',point-data-table-name 'point-id)
 973          'footprint 'footprint-device-stage-of-life-id
 974          'trigger-time
 975          'coordinates                   ;the search target
 976          (:as (:st_x (:st_transform 'coordinates *standard-coordinates*))
 977               'longitude)
 978          (:as (:st_y (:st_transform 'coordinates *standard-coordinates*))
 979               'latitude)
 980          (:as (:st_z (:st_transform 'coordinates *standard-coordinates*))
 981               'ellipsoid-height)
 982          'cartesian-system
 983          'east-sd 'north-sd 'height-sd
 984          'roll 'pitch 'heading 'roll-sd 'pitch-sd 'heading-sd
 985          'usable
 986          'sensor-width-pix 'sensor-height-pix 'pix-size
 987          'bayer-pattern 'color-raiser
 988          'mounting-angle
 989          'dx 'dy 'dz 'omega 'phi 'kappa
 990          'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
 991          'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
 992          'b-ddx 'b-ddy 'b-ddz 'b-drotx 'b-droty 'b-drotz
 993          'nx 'ny 'nz 'd
 994          :from
 995          'sys-measurement
 996          'sys-presentation
 997          ',point-data-table-name ',image-data-table-name
 998          'sys-device-stage-of-life 'sys-generic-device 'sys-camera-hardware
 999          'sys-camera-calibration
1000          :where
1001          (:and
1002           (:= (:dot ',image-data-table-name 'measurement-id)
1003               'sys-presentation.measurement-id)
1004           (:= 'sys-presentation.measurement-id
1005               'sys-measurement.measurement-id)
1006           (:= (:dot ',point-data-table-name 'point-id)
1007               (:dot ',image-data-table-name 'point-id))
1008           (:= (:dot ',image-data-table-name 'recorded-device-id)
1009               'sys-device-stage-of-life.recorded-device-id)
1010           (:= 'sys-generic-device.generic-device-id
1011               'sys-device-stage-of-life.generic-device-id)
1012           (:= 'sys-camera-hardware.camera-hardware-id
1013               'sys-generic-device.camera-hardware-id)
1014           (:= 'sys-device-stage-of-life.device-stage-of-life-id
1015               'sys-camera-calibration.device-stage-of-life-id)
1016           (:= 'sys-device-stage-of-life.device-stage-of-life-id
1017               (:limit
1018                (:order-by
1019                 (:select 'sys-camera-calibration.device-stage-of-life-id
1020                          :from 'sys-camera-calibration
1021                          :where
1022                          (:= 'sys-device-stage-of-life.device-stage-of-life-id
1023                              'sys-camera-calibration.device-stage-of-life-id))
1024                 (:desc 'date))
1025                1))
1026           (:<= (:extract :epoch 'sys-device-stage-of-life.mounting-date)
1027                (:- (:dot ',point-data-table-name 'trigger-time)
1028                    *unix-epoch*))
1029           (:or (:is-null 'sys-device-stage-of-life.unmounting-date)
1030                (:>= (:extract :epoch 'sys-device-stage-of-life.unmounting-date)
1031                     (:- (:dot ',point-data-table-name 'trigger-time)
1032                         *unix-epoch*))))))))
1033     (execute
1034      (format
1035       nil
1036       "CREATE OR REPLACE RULE ~A ~
1037          AS ON UPDATE TO ~A DO INSTEAD ~
1038            UPDATE ~A ~
1039              SET footprint = NEW.footprint, ~
1040              footprint_device_stage_of_life_id = OLD.device_stage_of_life_id
1041              WHERE byte_position = OLD.byte_position ~
1042                AND filename = OLD.filename ~
1043                AND measurement_id = OLD.measurement_id;"
1044       (s-sql:to-sql-name aggregate-view-update-rule-name)
1045       (s-sql:to-sql-name aggregate-view-name)
1046       (s-sql:to-sql-name image-data-table-name)))))
1047
1048 (defun aux-view-exists-p (presentation-project-name)
1049   "See if there is a view into auxiliary point table that belongs to
1050 presentation-project-name."
1051   (view-exists-p (aux-point-view-name presentation-project-name)))
1052
1053 (defun delete-aux-view (presentation-project-name)
1054   "Delete the view into auxiliary point table that belongs to
1055 presentation-project-name."
1056   (execute (format nil "DROP VIEW ~A CASCADE;"
1057                    (s-sql:to-sql-name (aux-point-view-name
1058                                        presentation-project-name))))
1059   (execute
1060    (format nil "DROP FUNCTION IF EXISTS ~
1061                 ~A(GEOMETRY, DOUBLE PRECISION, INT, DOUBLE PRECISION);"
1062            (s-sql:to-sql-name (thread-aux-points-function-name
1063                                presentation-project-name)))))
1064
1065 (defun* create-aux-view (presentation-project-name
1066                         &key (coordinates-column :the-geom)
1067                         numeric-columns text-columns
1068                         &mandatory-key aux-table)
1069   "Create a view into aux-table and an SQL function for threading
1070 aux-points into a linestring.  coordinates-column goes into column
1071 coordinates, numeric-columns and text-columns go into arrays in
1072 aux-numeric and aux-text respectively.
1073
1074 aux-table should have an index like so:
1075
1076 CREATE INDEX idx_<aux-table>_the_geom
1077   ON <aux-table>
1078   USING gist (the_geom);
1079
1080 VACUUM FULL ANALYZE <aux-table> (the_geom);"
1081   (create-plpgsql-helpers)
1082   (flet ((to-sql-name-or-null (name)
1083            (if name
1084                (s-sql:to-sql-name name)
1085                :null)))
1086     (let ((aux-point-view-name
1087            (aux-point-view-name presentation-project-name))
1088           (thread-aux-points-function-name
1089            (thread-aux-points-function-name presentation-project-name))
1090           (srid-count
1091            (query
1092             (:select (:as (:select (:count t)
1093                                    :from (make-symbol aux-table)
1094                                    :where (:<> (:st_srid (make-symbol coordinates-column))
1095                                                *standard-coordinates*))
1096                           'bad)
1097                      (:as (:select (:count (make-symbol coordinates-column))
1098                                    :from (make-symbol aux-table))
1099                           'total))
1100             :plist)))
1101       (unless (zerop (getf srid-count :bad))
1102         (warn "In column ~A of auxiliary data table ~A, ~D out of ~D values ~
1103               have currently an unsuitable SRID not equal to ~D."
1104               coordinates-column aux-table
1105               (getf srid-count :bad) (getf srid-count :total)
1106               *standard-coordinates*))
1107       (execute (format nil "
1108 CREATE VIEW ~A
1109 AS (SELECT ~A AS coordinates,
1110     ~:[NULL~;ARRAY[~:*~{~A~#^, ~}]~] AS aux_numeric,
1111     ~:[NULL~;ARRAY[~:*~{~A~#^, ~}]~] AS aux_text
1112     FROM ~A)"
1113                        (s-sql:to-sql-name aux-point-view-name)
1114                        (s-sql:to-sql-name coordinates-column)
1115                        (mapcar #'to-sql-name-or-null numeric-columns)
1116                        (mapcar #'to-sql-name-or-null text-columns)
1117                        (s-sql:to-sql-name aux-table)))
1118       (execute (format nil "~
1119 CREATE OR REPLACE FUNCTION ~0@*~A
1120   (point GEOMETRY, sample_radius DOUBLE PRECISION, sample_size INT,
1121    step_size DOUBLE PRECISION, old_azimuth DOUBLE PRECISION,
1122    max_bend DOUBLE PRECISION,
1123    OUT threaded_points TEXT,
1124    OUT current_point TEXT,
1125    OUT back_point TEXT, OUT forward_point TEXT,
1126    OUT new_azimuth DOUBLE PRECISION)
1127 AS
1128 $$
1129 -- Phoros version ~2@*~A
1130 DECLARE
1131   point_bag_size INT;
1132   current_point_position DOUBLE PRECISION;
1133   location DOUBLE PRECISION;
1134   line GEOMETRY;
1135   new_point point_bag%ROWTYPE;
1136   tried_point point_bag%ROWTYPE;
1137   previous_point point_bag%ROWTYPE;
1138   starting_point GEOMETRY;
1139   reversal_count INT DEFAULT 0;
1140 BEGIN
1141   -- Muffle warnings about implicitly created stuff:
1142   SET client_min_messages TO ERROR;
1143
1144   starting_point :=
1145     (SELECT coordinates
1146        FROM ~1@*~A
1147        WHERE
1148          coordinates
1149          &&
1150          st_setsrid(st_makebox3d (st_translate (point,
1151                                                 - sample_radius * 5,
1152                                                 - sample_radius * 5, 0),
1153                                   st_translate (point,
1154                                                 sample_radius * 5,
1155                                                 sample_radius * 5, 0)),
1156                     4326)
1157        ORDER BY st_distance(coordinates, point)
1158        LIMIT 1);
1159
1160   CREATE TEMPORARY TABLE point_bag
1161     (id SERIAL primary key, coordinates GEOMETRY)
1162     ON COMMIT DROP;
1163
1164   INSERT INTO point_bag (coordinates)
1165     SELECT coordinates
1166       FROM ~1@*~A
1167
1168       WHERE
1169         coordinates
1170         &&
1171         st_setsrid(st_makebox3d (st_translate (starting_point,
1172                                                - sample_radius,
1173                                                - sample_radius, 0),
1174                                  st_translate (starting_point,
1175                                                sample_radius,
1176                                                sample_radius, 0)),
1177                    4326)
1178         AND st_distance (coordinates, starting_point) < sample_radius
1179       ORDER BY st_distance (coordinates, starting_point)
1180       LIMIT sample_size;
1181
1182   point_bag_size := (SELECT count(*) from point_bag);
1183
1184   -- emergency point_bag:
1185   IF point_bag_size < 5
1186   THEN
1187     DROP TABLE point_bag;
1188     CREATE TEMPORARY TABLE point_bag
1189       (id SERIAL primary key, coordinates GEOMETRY)
1190       ON COMMIT DROP;
1191     INSERT INTO point_bag (coordinates)
1192       SELECT coordinates
1193         FROM ~1@*~A
1194         WHERE
1195           coordinates
1196           &&
1197           st_setsrid(st_makebox3d (st_translate (point,
1198                                                  - sample_radius * 100,
1199                                                  - sample_radius * 100, 0),
1200                                    st_translate (point,
1201                                                  sample_radius * 100,
1202                                                  sample_radius * 100, 0)),
1203                      4326)
1204         ORDER BY st_distance (coordinates, starting_point)
1205         LIMIT 5;
1206     starting_point := (SELECT coordinates FROM point_bag where id = 3);
1207   END IF;
1208
1209   previous_point :=
1210     (SELECT ROW(id, coordinates)
1211        FROM point_bag
1212        ORDER BY st_distance (point_bag.coordinates, starting_point)
1213        LIMIT 1);
1214
1215   DELETE FROM point_bag WHERE id = previous_point.id;
1216
1217   new_point :=
1218     (SELECT ROW(id, coordinates)
1219        FROM point_bag
1220        ORDER BY st_distance (point_bag.coordinates, previous_point.coordinates)
1221        LIMIT 1);
1222
1223   line := st_makeline(previous_point.coordinates,
1224                       new_point.coordinates);
1225
1226   new_azimuth :=
1227     st_azimuth(previous_point.coordinates, new_point.coordinates);
1228
1229   IF abs(new_azimuth - old_azimuth) > radians(90)
1230      AND
1231      abs(new_azimuth - old_azimuth) < radians(270)
1232   THEN
1233     new_azimuth :=
1234       st_azimuth(new_point.coordinates, previous_point.coordinates);
1235     line := st_reverse(line);
1236   END IF;
1237
1238   DELETE FROM point_bag WHERE id = new_point.id;
1239
1240   LOOP
1241     previous_point.coordinates := st_pointn(line,1);
1242
1243     new_point :=
1244       (SELECT ROW(id, coordinates)
1245          FROM point_bag
1246          ORDER BY st_distance (coordinates, previous_point.coordinates)
1247          LIMIT 1);
1248
1249     EXIT WHEN new_point IS NULL;
1250
1251     IF bendedness(st_pointn(line, 2), st_pointn(line, 1),
1252                   new_point.coordinates)
1253        < bendedness(st_pointn(line, st_npoints(line) - 1),
1254                     st_pointn(line, st_npoints(line)), new_point.coordinates)
1255        AND
1256        bendedness(st_pointn(line, 2), st_pointn(line, 1),
1257                    new_point.coordinates)
1258        < max_bend
1259     THEN
1260         line := st_addpoint(line, new_point.coordinates, 0);
1261         DELETE FROM point_bag WHERE id = new_point.id;
1262     END IF;
1263
1264     line := st_reverse(line);
1265
1266     reversal_count := reversal_count + 1 ;
1267
1268     DELETE FROM point_bag WHERE id = tried_point.id;
1269
1270     tried_point := new_point;
1271   END LOOP;
1272
1273   IF mod(reversal_count, 2) = 1
1274   THEN
1275     line := st_reverse(line);
1276   END IF;
1277
1278   current_point_position :=
1279     st_line_locate_point(line, point);
1280
1281   current_point :=
1282     st_astext(st_line_interpolate_point(line, current_point_position));
1283
1284   location := (current_point_position - (step_size / st_length(line)));
1285   IF location < 0 THEN location := 0; END IF;
1286
1287   back_point :=
1288     st_astext(st_line_interpolate_point(line, location));
1289
1290   location := (current_point_position + (step_size / st_length(line)));
1291   IF location > 0 THEN location := 1; END IF;
1292
1293   forward_point :=
1294     st_astext(st_line_interpolate_point(line, location));
1295
1296   threaded_points := st_astext(line);
1297
1298   RETURN;
1299 END;
1300 $$ LANGUAGE plpgsql;"
1301                        (s-sql:to-sql-name thread-aux-points-function-name)
1302                        (s-sql:to-sql-name aux-point-view-name)
1303                        (phoros-version))))))
1304
1305 (defun create-acquisition-project (common-table-name)
1306   "Create in current database a fresh set of canonically named tables.
1307 common-table-name should in most cases resemble the project name and
1308 will be stored in table sys-acquisition-project, field
1309 common-table-name."
1310   (create-data-table-definitions common-table-name)
1311   (handler-case (create-sys-tables) ;Create system tables if necessary.
1312     (cl-postgres-error:syntax-error-or-access-violation () nil))
1313   (assert-phoros-db-major-version)
1314   (when (select-dao 'sys-acquisition-project
1315                     (:= 'common-table-name
1316                         (s-sql:to-sql-name common-table-name)))
1317     (error "There is already a row with a common-table-name of ~A in table ~A."
1318            common-table-name
1319            (s-sql:to-sql-name (dao-table-name 'sys-acquisition-project))))
1320   (create-table 'point-data)
1321   (create-table 'image-data)
1322   (create-aggregate-view common-table-name)
1323   (insert-dao
1324    (make-instance 'sys-acquisition-project
1325                   :common-table-name common-table-name)))
1326
1327 (defun delete-acquisition-project (common-table-name)
1328   "Delete the acquisition project that uses common-table-name.  Return
1329 nil if there wasn't any."
1330   (assert-phoros-db-major-version)
1331   (let ((project
1332          (car (select-dao 'sys-acquisition-project
1333                           (:= 'common-table-name common-table-name)))))
1334     (when project
1335       (delete-dao project)
1336       (execute (:drop-view
1337                 :if-exists (aggregate-view-name common-table-name)))
1338       (execute (:drop-table
1339                 :if-exists (image-data-table-name common-table-name)))
1340       (execute (:drop-table
1341                 :if-exists (point-data-table-name common-table-name)))
1342       (execute (:drop-sequence
1343                 :if-exists (point-id-seq-name common-table-name))))))
1344
1345 (defun delete-measurement (measurement-id)
1346   "Delete measurement with measurement-id if any; return nil if not."
1347   (assert-phoros-db-major-version)
1348   (let ((measurement (get-dao 'sys-measurement measurement-id)))
1349     (when measurement (delete-dao measurement))))
1350
1351 (defun create-presentation-project (project-name)
1352   "Create a fresh presentation project in current database.  Return
1353 dao if one was created, or nil if it existed already."
1354   (assert-phoros-db-major-version)
1355   (unless (get-dao 'sys-presentation-project project-name)
1356     (create-user-table-definition project-name)
1357     (create-table 'user-point)
1358     (create-presentation-project-trigger-function project-name)
1359     (execute (format nil "DROP TRIGGER IF EXISTS ~A ON ~:*~A;"
1360                      (s-sql:to-sql-name (user-point-table-name project-name))))
1361     (execute (format nil "
1362 CREATE TRIGGER ~A
1363   AFTER INSERT OR UPDATE OR DELETE
1364   ON ~:*~A
1365   FOR EACH ROW EXECUTE PROCEDURE ~:*~A();"
1366                      (s-sql:to-sql-name (user-point-table-name project-name))))
1367     (execute (sql-compile
1368               `(:create-table ,(user-line-table-name project-name)
1369                               ((description :type text)
1370                                ;; description would be a nice primary
1371                                ;; key if it wasn't for QGIS which
1372                                ;; needs it numeric
1373                                (id :type serial :primary-key t)
1374                                (line :type geometry)))))
1375     (insert-dao (make-instance 'sys-presentation-project
1376                                :presentation-project-name project-name))))
1377
1378 (defun create-presentation-project-trigger-function
1379     (presentation-project
1380      &optional (plpgsql-body
1381                 (format
1382                  nil "  RAISE NOTICE 'trigger fired: ~A';"
1383                  (s-sql:to-sql-name (user-point-table-name
1384                                      presentation-project))))
1385      &rest plpgsql-body-args)
1386   "(Re)create in current database an SQL trigger function with
1387 plpgsql-body (a format string that uses plpgsql-body-args)."
1388   (execute (format
1389             nil "
1390 CREATE OR REPLACE FUNCTION ~A() RETURNS trigger
1391 AS
1392 $$
1393 BEGIN
1394   ------------------------------------------
1395   -- Define your trigger actions below:
1396   ------------------------------------------
1397 ~?~&~:
1398   ------------------------------------------
1399   -- End of your trigger action definitions.
1400   ------------------------------------------
1401   RETURN NULL;
1402 END;
1403 $$ LANGUAGE plpgsql;"
1404             (s-sql:to-sql-name (user-point-table-name presentation-project))
1405             plpgsql-body
1406             plpgsql-body-args)))
1407
1408 (defun fire-presentation-project-trigger-function (presentation-project)
1409   "Tickle user point table of presentation-project so it fires its
1410 trigger."
1411   (let ((user-point-table (user-point-table-name presentation-project)))
1412     (execute
1413      (:update user-point-table
1414               :set 'user-point-id 'user-point-id
1415               :where (:= 'user-point-id
1416                          (:limit (:select 'user-point-id
1417                                           :from user-point-table) 1))))))
1418
1419 (defun delete-presentation-project (project-name)
1420   "Delete the presentation project project-name.  Return nil if there
1421 wasn't any."
1422   (assert-phoros-db-major-version)
1423   (let ((project (get-dao 'sys-presentation-project project-name)))
1424     (when project
1425       (delete-dao project)
1426       (execute
1427        (:drop-table :if-exists (user-point-table-name project-name)))
1428       (execute
1429        (:drop-sequence :if-exists (user-point-id-seq-name project-name)))
1430       (execute
1431        (:drop-table :if-exists (user-line-table-name project-name))))))
1432
1433 (defun postmodern-as-clauses (row-alist)
1434   "Make a list of constant :as clauses from query result row-alist.
1435 Alias names are the column names from row-alist prefixed by first-."
1436   (loop
1437      for column in row-alist
1438      collect `(:as
1439                ,(cdr column)
1440                ,(intern (string (prefix-aggregate-view-column (car column)))
1441                         'keyword))))
1442
1443 (defun prefix-aggregate-view-column (column-name)
1444   "Return a symbol named column-name, prefixed by first-."
1445   (make-symbol (concatenate 'string
1446                             (string 'first-)
1447                             (string column-name))))
1448
1449 (defun some-internal-image-reference (sql-clause)
1450   "Return t if there are occurences of
1451 first-<something-from-*aggregate-view-columns*>, which act as
1452 references to the first image."
1453   (loop
1454      for i in *aggregate-view-columns*
1455      thereis
1456        (ppcre:scan
1457         (ppcre:create-scanner
1458          (s-sql:to-sql-name (prefix-aggregate-view-column i))
1459          :case-insensitive-mode
1460          t)
1461         sql-clause)))
1462
1463 (defun* create-image-attribute (presentation-project-name
1464                                &mandatory-key tag sql-clause)
1465   "Store a boolean SQL expression into current database.  Return SQL
1466 expression previously stored for presentation-project-name and tag if
1467 any; return nil otherwise.  Second return value is the number of
1468 images covered by the SQL expression, and third return value is the
1469 total number of images in presentation project.  Both second and third
1470 return value are nil if sql-clause contains references to the first
1471 image."
1472   (assert-phoros-db-major-version)
1473   (let* ((presentation-project-id
1474           (presentation-project-id-from-name presentation-project-name))
1475          (old-selectable-restriction
1476           (get-dao 'sys-selectable-restriction presentation-project-id tag))
1477          (common-table-names
1478           (common-table-names presentation-project-id))
1479          (selected-restrictions-conjunction
1480           (sql-where-conjunction (list sql-clause)))
1481          (arbitrary-image-query
1482           (sql-compile
1483            `(:union
1484              ,@(loop
1485                   for common-table-name in common-table-names
1486                   for aggregate-view-name
1487                   = (aggregate-view-name common-table-name)
1488                   collect
1489                     `(:limit (:select ,@*aggregate-view-columns*
1490                                       :from ',aggregate-view-name)
1491                              1)))))
1492          (internal-reference-p (some-internal-image-reference sql-clause))
1493          (arbitrary-image (query arbitrary-image-query :alist))
1494          (counting-selected-query
1495           ;; Only useful as an SQL syntax check if sql-clause contains
1496           ;; internal references.
1497           (sql-compile
1498            `(:select
1499              (:sum count)
1500              :from
1501              (:as
1502               (:union
1503                ,@(loop
1504                     for common-table-name in common-table-names
1505                     for aggregate-view-name
1506                     = (aggregate-view-name common-table-name)
1507                     collect
1508                     `(:select
1509                       (:as (:count t) 'count)
1510                       :from
1511                       (:as
1512                        (:select
1513                         ,@(postmodern-as-clauses arbitrary-image)
1514                         '*
1515                         :from ',aggregate-view-name)
1516                        'images-of-acquisition-project-plus-reference-image)
1517                       :where
1518                       (:and (:= 'presentation-project-id
1519                                 ,presentation-project-id)
1520                             (:raw ,selected-restrictions-conjunction)))))
1521               'acquisition-project-image-counts))))
1522          (counting-total-query
1523           (sql-compile
1524            `(:select
1525              (:sum count)
1526              :from
1527              (:as (:union
1528                    ,@(loop
1529                         for common-table-name in common-table-names
1530                         for aggregate-view-name
1531                         = (aggregate-view-name common-table-name)
1532                         collect
1533                         `(:select
1534                           (:as (:count '*) 'count)
1535                           :from ',aggregate-view-name
1536                           :where (:= 'presentation-project-id
1537                                      ,presentation-project-id))))
1538                   'acquisition-project-image-counts))))
1539          (number-of-selected-images
1540           (if common-table-names ;otherwise: presentation-project is empty
1541               (query counting-selected-query :single!)
1542               0))
1543          (total-number-of-images
1544           (unless internal-reference-p    ;otherwise don't waste time
1545             (if common-table-names ;otherwise: presentation-project is empty
1546                 (query counting-total-query :single!)
1547                 0))))
1548     (save-dao (make-instance 'sys-selectable-restriction
1549                              :presentation-project-id presentation-project-id
1550                              :restriction-id tag :sql-clause sql-clause))
1551     (values
1552      (when old-selectable-restriction (sql-clause old-selectable-restriction))
1553      (if internal-reference-p nil number-of-selected-images)
1554      (if internal-reference-p nil total-number-of-images))))
1555
1556 (defun* delete-image-attribute (presentation-project-name &mandatory-key tag)
1557   "Delete SQL expression stored with tag under
1558 presentation-project-name from current database.  Return the SQL
1559 expression deleted if there was any; return nil otherwise."
1560   (assert-phoros-db-major-version)
1561   (let ((selectable-restriction
1562          (get-dao 'sys-selectable-restriction
1563                   (presentation-project-id-from-name presentation-project-name)
1564                   tag)))
1565     (when selectable-restriction
1566       (delete-dao selectable-restriction)
1567       (sql-clause selectable-restriction))))
1568
1569 (defun* create-user (name &key
1570                           presentation-projects
1571                           &mandatory-key
1572                           user-password
1573                           user-full-name
1574                           user-role)
1575   "Create a fresh user entry or update an existing one with matching
1576 name.  Assign it presentation-projects, deleting any previously
1577 existing assignments."
1578   (assert-phoros-db-major-version)
1579   (assert (or (string-equal "read" user-role)
1580               (string-equal "write" user-role)
1581               (string-equal "admin" user-role))
1582           (user-role)
1583           "~A is not a valid user-role." user-role)
1584   (let ((user (or (car (select-dao 'sys-user (:= 'user-name name)))
1585                   (make-instance 'sys-user :user-name name)))
1586         fresh-user-p)
1587     (setf (user-password user) user-password
1588           (user-full-name user) user-full-name)
1589     (setf fresh-user-p (save-dao user))
1590     (mapcar #'delete-dao (select-dao 'sys-user-role
1591                                      (:= 'user-id (user-id user))))
1592     (dolist (presentation-project-name presentation-projects)
1593       (let ((presentation-project
1594              (get-dao 'sys-presentation-project presentation-project-name)))
1595         (if presentation-project
1596             (insert-dao
1597              (make-instance
1598               'sys-user-role
1599               :user-id (user-id user)
1600               :presentation-project-id
1601               (presentation-project-id presentation-project)
1602               :user-role (string-downcase user-role))) ;TODO: we should be able to set role per presentation-project.
1603             (warn
1604              "There is no presentation project ~A" presentation-project-name))))
1605     fresh-user-p))
1606
1607 (defun delete-user (user-name)
1608   "Delete user user-name if any; return nil if not."
1609   (assert-phoros-db-major-version)
1610   (let ((user (car (select-dao 'sys-user (:= 'user-name user-name)))))
1611     (when user (delete-dao user))))
1612
1613 (defun add-to-presentation-project (presentation-project-name
1614                                     &key measurement-ids acquisition-project)
1615   "Add to presentation project presentation-project-name either a list
1616 of measurements (with measurement-id) or all measurements currently in
1617 acquisition-project (denoted by its common-table-name)."
1618   (assert-phoros-db-major-version)
1619   (let* ((presentation-project
1620           (car (select-dao 'sys-presentation-project
1621                            (:= 'presentation-project-name
1622                                presentation-project-name))))
1623          (presentation-project-id
1624           (presentation-project-id presentation-project)))
1625     (flet ((add-measurement (measurement-id)
1626              "Add one measurement to the given presentation-project."
1627              (unless (get-dao 'sys-presentation
1628                               presentation-project-id
1629                               measurement-id)
1630                (insert-dao
1631                 (make-instance 'sys-presentation
1632                                :presentation-project-id presentation-project-id
1633                                :measurement-id measurement-id)))))
1634       (cond (measurement-ids (mapc #'add-measurement measurement-ids))
1635             (acquisition-project
1636              (dolist
1637                  (measurement-id
1638                    (query
1639                     (:select
1640                      'measurement-id
1641                      :from 'sys-measurement 'sys-acquisition-project
1642                      :where (:and
1643                              (:= 'sys-acquisition-project.common-table-name
1644                                  acquisition-project)
1645                              (:= 'sys-measurement.acquisition-project-id
1646                                  'sys-acquisition-project.acquisition-project-id)))
1647                     :column))
1648                (add-measurement measurement-id)))
1649             (t (error
1650                 "Don't know what to add.  ~
1651                  Need either measurement-id or acquisition-project."))))
1652     (let* ((common-table-names
1653             (common-table-names presentation-project-id))
1654            (presentation-project-bounding-box
1655             (ignore-errors             ;for empty presentation project
1656               (substitute
1657                #\, #\Space
1658                (string-trim
1659                 "BOX()"
1660                 (query
1661                  (sql-compile
1662                   `(:select
1663                     (:st_extent 'coordinates)
1664                     :from
1665                     (:as (:union
1666                           ,@(loop
1667                                for common-table-name in common-table-names
1668                                for point-table-name
1669                                = (point-data-table-name common-table-name)
1670                                ;; would have been nice, was too slow:
1671                                ;; = (aggregate-view-name common-table-name)
1672                                collect
1673                                `(:select
1674                                  'coordinates
1675                                  :from ',point-table-name
1676                                  :natural :left-join 'sys-presentation
1677                                  :where
1678                                  (:= 'presentation-project-id
1679                                      ,presentation-project-id))))
1680                          all-coordinates)))
1681                  :single!))))))
1682       (when presentation-project-bounding-box
1683         (setf (bounding-box presentation-project)
1684               presentation-project-bounding-box))
1685       (update-dao presentation-project))))
1686
1687 (defun remove-from-presentation-project (presentation-project-name
1688                                          &key measurement-ids acquisition-project)
1689   "Remove from presentation project presentation-project-name either a
1690 list of measurements (with measurement-id) or all measurements
1691 currently in acquisition-project with (denoted by its
1692 common-table-name).  Return nil if there weren't anything to remove."
1693   (assert-phoros-db-major-version)
1694   (let* ((presentation-project
1695           (car (select-dao 'sys-presentation-project
1696                            (:= 'presentation-project-name
1697                                presentation-project-name))))
1698          (presentation-project-id
1699           (Presentation-project-id presentation-project)))
1700     (flet ((remove-measurement (measurement-id)
1701              (let ((measurement
1702                     (car (select-dao
1703                           'sys-presentation
1704                           (:and (:= 'measurement-id measurement-id)
1705                                 (:= 'presentation-project-id
1706                                     presentation-project-id))))))
1707                (when measurement (delete-dao measurement)))))
1708     (cond (measurement-ids (mapc #'remove-measurement measurement-ids))
1709           (acquisition-project
1710            (dolist
1711                (measurement-id
1712                  (query
1713                   (:select
1714                    'measurement-id
1715                    :from 'sys-measurement 'sys-acquisition-project
1716                    :where (:and
1717                            (:= 'sys-acquisition-project.common-table-name
1718                                acquisition-project)
1719                            (:= 'sys-measurement.acquisition-project-id
1720                                'sys-acquisition-project.acquisition-project-id)))
1721                   :column))
1722              (remove-measurement measurement-id)))
1723           (t (error
1724               "Don't know what to remove.  ~
1725                Need either measurement-id or acquisition-project."))))))
1726
1727