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   (let ((aux-point-view-name
1083          (aux-point-view-name presentation-project-name))
1084         (thread-aux-points-function-name
1085          (thread-aux-points-function-name presentation-project-name)))
1086     (execute (format nil "
1087 CREATE VIEW ~A
1088 AS (SELECT ~A AS coordinates,
1089     ~:[NULL~;ARRAY[~:*~{~A~#^, ~}]~] AS aux_numeric,
1090     ~:[NULL~;ARRAY[~:*~{~A~#^, ~}]~] AS aux_text
1091     FROM ~A)"
1092                      (s-sql:to-sql-name aux-point-view-name)
1093                      coordinates-column
1094                      (mapcar #'s-sql:to-sql-name numeric-columns)
1095                      (mapcar #'s-sql:to-sql-name text-columns)
1096                      (s-sql:to-sql-name aux-table)))
1097     (execute (format nil "~
1098 CREATE OR REPLACE FUNCTION ~0@*~A
1099   (point GEOMETRY, sample_radius DOUBLE PRECISION, sample_size INT,
1100    step_size DOUBLE PRECISION, old_azimuth DOUBLE PRECISION,
1101    max_bend DOUBLE PRECISION,
1102    OUT threaded_points TEXT,
1103    OUT current_point TEXT,
1104    OUT back_point TEXT, OUT forward_point TEXT,
1105    OUT new_azimuth DOUBLE PRECISION)
1106 AS
1107 $$
1108 -- Phoros version ~2@*~A
1109 DECLARE
1110   point_bag_size INT;
1111   current_point_position DOUBLE PRECISION;
1112   location DOUBLE PRECISION;
1113   line GEOMETRY;
1114   new_point point_bag%ROWTYPE;
1115   tried_point point_bag%ROWTYPE;
1116   previous_point point_bag%ROWTYPE;
1117   starting_point GEOMETRY;
1118   reversal_count INT DEFAULT 0;
1119 BEGIN
1120   -- Muffle warnings about implicitly created stuff:
1121   SET client_min_messages TO ERROR;
1122
1123   starting_point :=
1124     (SELECT coordinates
1125        FROM ~1@*~A
1126        WHERE
1127          coordinates
1128          &&
1129          st_setsrid(st_makebox3d (st_translate (point,
1130                                                 - sample_radius * 5,
1131                                                 - sample_radius * 5, 0),
1132                                   st_translate (point,
1133                                                 sample_radius * 5,
1134                                                 sample_radius * 5, 0)),
1135                     4326)
1136        ORDER BY st_distance(coordinates, point)
1137        LIMIT 1);
1138
1139   CREATE TEMPORARY TABLE point_bag
1140     (id SERIAL primary key, coordinates GEOMETRY)
1141     ON COMMIT DROP;
1142
1143   INSERT INTO point_bag (coordinates)
1144     SELECT coordinates
1145       FROM ~1@*~A
1146
1147       WHERE
1148         coordinates
1149         &&
1150         st_setsrid(st_makebox3d (st_translate (starting_point,
1151                                                - sample_radius,
1152                                                - sample_radius, 0),
1153                                  st_translate (starting_point,
1154                                                sample_radius,
1155                                                sample_radius, 0)),
1156                    4326)
1157         AND st_distance (coordinates, starting_point) < sample_radius
1158       ORDER BY st_distance (coordinates, starting_point)
1159       LIMIT sample_size;
1160
1161   point_bag_size := (SELECT count(*) from point_bag);
1162
1163   -- emergency point_bag:
1164   IF point_bag_size < 5
1165   THEN
1166     DROP TABLE point_bag;
1167     CREATE TEMPORARY TABLE point_bag
1168       (id SERIAL primary key, coordinates GEOMETRY)
1169       ON COMMIT DROP;
1170     INSERT INTO point_bag (coordinates)
1171       SELECT coordinates
1172         FROM ~1@*~A
1173         WHERE
1174           coordinates
1175           &&
1176           st_setsrid(st_makebox3d (st_translate (point,
1177                                                  - sample_radius * 100,
1178                                                  - sample_radius * 100, 0),
1179                                    st_translate (point,
1180                                                  sample_radius * 100,
1181                                                  sample_radius * 100, 0)),
1182                      4326)
1183         ORDER BY st_distance (coordinates, starting_point)
1184         LIMIT 5;
1185     starting_point := (SELECT coordinates FROM point_bag where id = 3);
1186   END IF;
1187
1188   previous_point :=
1189     (SELECT ROW(id, coordinates)
1190        FROM point_bag
1191        ORDER BY st_distance (point_bag.coordinates, starting_point)
1192        LIMIT 1);
1193
1194   DELETE FROM point_bag WHERE id = previous_point.id;
1195
1196   new_point :=
1197     (SELECT ROW(id, coordinates)
1198        FROM point_bag
1199        ORDER BY st_distance (point_bag.coordinates, previous_point.coordinates)
1200        LIMIT 1);
1201
1202   line := st_makeline(previous_point.coordinates,
1203                       new_point.coordinates);
1204
1205   new_azimuth :=
1206     st_azimuth(previous_point.coordinates, new_point.coordinates);
1207
1208   IF abs(new_azimuth - old_azimuth) > radians(90)
1209      AND
1210      abs(new_azimuth - old_azimuth) < radians(270)
1211   THEN
1212     new_azimuth :=
1213       st_azimuth(new_point.coordinates, previous_point.coordinates);
1214     line := st_reverse(line);
1215   END IF;
1216
1217   DELETE FROM point_bag WHERE id = new_point.id;
1218
1219   LOOP
1220     previous_point.coordinates := st_pointn(line,1);
1221
1222     new_point :=
1223       (SELECT ROW(id, coordinates)
1224          FROM point_bag
1225          ORDER BY st_distance (coordinates, previous_point.coordinates)
1226          LIMIT 1);
1227
1228     EXIT WHEN new_point IS NULL;
1229
1230     IF bendedness(st_pointn(line, 2), st_pointn(line, 1),
1231                   new_point.coordinates)
1232        < bendedness(st_pointn(line, st_npoints(line) - 1),
1233                     st_pointn(line, st_npoints(line)), new_point.coordinates)
1234        AND
1235        bendedness(st_pointn(line, 2), st_pointn(line, 1),
1236                    new_point.coordinates)
1237        < max_bend
1238     THEN
1239         line := st_addpoint(line, new_point.coordinates, 0);
1240         DELETE FROM point_bag WHERE id = new_point.id;
1241     END IF;
1242
1243     line := st_reverse(line);
1244
1245     reversal_count := reversal_count + 1 ;
1246
1247     DELETE FROM point_bag WHERE id = tried_point.id;
1248
1249     tried_point := new_point;
1250   END LOOP;
1251
1252   IF mod(reversal_count, 2) = 1
1253   THEN
1254     line := st_reverse(line);
1255   END IF;
1256
1257   current_point_position :=
1258     st_line_locate_point(line, point);
1259
1260   current_point :=
1261     st_astext(st_line_interpolate_point(line, current_point_position));
1262
1263   location := (current_point_position - (step_size / st_length(line)));
1264   IF location < 0 THEN location := 0; END IF;
1265
1266   back_point :=
1267     st_astext(st_line_interpolate_point(line, location));
1268
1269   location := (current_point_position + (step_size / st_length(line)));
1270   IF location > 0 THEN location := 1; END IF;
1271
1272   forward_point :=
1273     st_astext(st_line_interpolate_point(line, location));
1274
1275   threaded_points := st_astext(line);
1276
1277   RETURN;
1278 END;
1279 $$ LANGUAGE plpgsql;"
1280                      (s-sql:to-sql-name thread-aux-points-function-name)
1281                      (s-sql:to-sql-name aux-point-view-name)
1282                      (phoros-version)))))
1283
1284 (defun create-acquisition-project (common-table-name)
1285   "Create in current database a fresh set of canonically named tables.
1286 common-table-name should in most cases resemble the project name and
1287 will be stored in table sys-acquisition-project, field
1288 common-table-name."
1289   (create-data-table-definitions common-table-name)
1290   (handler-case (create-sys-tables) ;Create system tables if necessary.
1291     (cl-postgres-error:syntax-error-or-access-violation () nil))
1292   (assert-phoros-db-major-version)
1293   (when (select-dao 'sys-acquisition-project
1294                     (:= 'common-table-name
1295                         (s-sql:to-sql-name common-table-name)))
1296     (error "There is already a row with a common-table-name of ~A in table ~A."
1297            common-table-name
1298            (s-sql:to-sql-name (dao-table-name 'sys-acquisition-project))))
1299   (create-table 'point-data)
1300   (create-table 'image-data)
1301   (create-aggregate-view common-table-name)
1302   (insert-dao
1303    (make-instance 'sys-acquisition-project
1304                   :common-table-name common-table-name)))
1305
1306 (defun delete-acquisition-project (common-table-name)
1307   "Delete the acquisition project that uses common-table-name.  Return
1308 nil if there wasn't any."
1309   (assert-phoros-db-major-version)
1310   (let ((project
1311          (car (select-dao 'sys-acquisition-project
1312                           (:= 'common-table-name common-table-name)))))
1313     (when project
1314       (delete-dao project)
1315       (execute (:drop-view
1316                 :if-exists (aggregate-view-name common-table-name)))
1317       (execute (:drop-table
1318                 :if-exists (image-data-table-name common-table-name)))
1319       (execute (:drop-table
1320                 :if-exists (point-data-table-name common-table-name)))
1321       (execute (:drop-sequence
1322                 :if-exists (point-id-seq-name common-table-name))))))
1323
1324 (defun delete-measurement (measurement-id)
1325   "Delete measurement with measurement-id if any; return nil if not."
1326   (assert-phoros-db-major-version)
1327   (let ((measurement (get-dao 'sys-measurement measurement-id)))
1328     (when measurement (delete-dao measurement))))
1329
1330 (defun create-presentation-project (project-name)
1331   "Create a fresh presentation project in current database.  Return
1332 dao if one was created, or nil if it existed already."
1333   (assert-phoros-db-major-version)
1334   (unless (get-dao 'sys-presentation-project project-name)
1335     (create-user-table-definition project-name)
1336     (create-table 'user-point)
1337     (create-presentation-project-trigger-function project-name)
1338     (execute (format nil "DROP TRIGGER IF EXISTS ~A ON ~:*~A;"
1339                      (s-sql:to-sql-name (user-point-table-name project-name))))
1340     (execute (format nil "
1341 CREATE TRIGGER ~A
1342   AFTER INSERT OR UPDATE OR DELETE
1343   ON ~:*~A
1344   FOR EACH ROW EXECUTE PROCEDURE ~:*~A();"
1345                      (s-sql:to-sql-name (user-point-table-name project-name))))
1346     (execute (sql-compile
1347               `(:create-table ,(user-line-table-name project-name)
1348                               ((description :type text)
1349                                ;; description would be a nice primary
1350                                ;; key if it wasn't for QGIS which
1351                                ;; needs it numeric
1352                                (id :type serial :primary-key t)
1353                                (line :type geometry)))))
1354     (insert-dao (make-instance 'sys-presentation-project
1355                                :presentation-project-name project-name))))
1356
1357 (defun create-presentation-project-trigger-function
1358     (presentation-project
1359      &optional (plpgsql-body
1360                 (format
1361                  nil "  RAISE NOTICE 'trigger fired: ~A';"
1362                  (s-sql:to-sql-name (user-point-table-name
1363                                      presentation-project))))
1364      &rest plpgsql-body-args)
1365   "(Re)create in current database an SQL trigger function with
1366 plpgsql-body (a format string that uses plpgsql-body-args)."
1367   (execute (format
1368             nil "
1369 CREATE OR REPLACE FUNCTION ~A() RETURNS trigger
1370 AS
1371 $$
1372 BEGIN
1373   ------------------------------------------
1374   -- Define your trigger actions below:
1375   ------------------------------------------
1376 ~?~&~:
1377   ------------------------------------------
1378   -- End of your trigger action definitions.
1379   ------------------------------------------
1380   RETURN NULL;
1381 END;
1382 $$ LANGUAGE plpgsql;"
1383             (s-sql:to-sql-name (user-point-table-name presentation-project))
1384             plpgsql-body
1385             plpgsql-body-args)))
1386
1387 (defun fire-presentation-project-trigger-function (presentation-project)
1388   "Tickle user point table of presentation-project so it fires its
1389 trigger."
1390   (let ((user-point-table (user-point-table-name presentation-project)))
1391     (execute
1392      (:update user-point-table
1393               :set 'user-point-id 'user-point-id
1394               :where (:= 'user-point-id
1395                          (:limit (:select 'user-point-id
1396                                           :from user-point-table) 1))))))
1397
1398 (defun delete-presentation-project (project-name)
1399   "Delete the presentation project project-name.  Return nil if there
1400 wasn't any."
1401   (assert-phoros-db-major-version)
1402   (let ((project (get-dao 'sys-presentation-project project-name)))
1403     (when project
1404       (delete-dao project)
1405       (execute
1406        (:drop-table :if-exists (user-point-table-name project-name)))
1407       (execute
1408        (:drop-sequence :if-exists (user-point-id-seq-name project-name)))
1409       (execute
1410        (:drop-table :if-exists (user-line-table-name project-name))))))
1411
1412 (defun* create-image-attribute (presentation-project-name
1413                                &mandatory-key tag sql-clause)
1414   "Store a boolean SQL expression into current database.  Return SQL
1415 expression previously stored for presentation-project-name and tag if
1416 any; return nil otherwise.  Second return value is the number of
1417 images covered by the SQL expression, and third return value is the
1418 total number of images in presentation project."
1419   (assert-phoros-db-major-version)
1420   (let* ((presentation-project-id
1421           (presentation-project-id-from-name presentation-project-name))
1422          (old-selectable-restriction
1423           (get-dao 'sys-selectable-restriction presentation-project-id tag))
1424          (common-table-names
1425           (common-table-names presentation-project-id))
1426          (selected-restrictions-conjunction
1427           (sql-where-conjunction (list sql-clause)))
1428          (counting-selected-query
1429           (sql-compile
1430            `(:select
1431              (:sum count)
1432              :from
1433              (:as (:union
1434                    ,@(loop
1435                         for common-table-name in common-table-names
1436                         for aggregate-view-name
1437                         = (aggregate-view-name common-table-name)
1438                         collect
1439                         `(:select
1440                           (:as (:count '*) 'count)
1441                           :from
1442                           ',aggregate-view-name
1443                           :where
1444                           (:and (:= 'presentation-project-id
1445                                     ,presentation-project-id)
1446                                 (:raw ,selected-restrictions-conjunction)))))
1447                   'count))))
1448          (counting-total-query
1449           (sql-compile
1450            `(:select
1451              (:sum count)
1452              :from
1453              (:as (:union
1454                    ,@(loop
1455                         for common-table-name in common-table-names
1456                         for aggregate-view-name
1457                         = (aggregate-view-name common-table-name)
1458                         collect
1459                         `(:select
1460                           (:as (:count '*) 'count)
1461                           :from
1462                           ',aggregate-view-name
1463                           :where
1464                           (:= 'presentation-project-id
1465                               ,presentation-project-id))))
1466                   'count))))
1467          (number-of-selected-images
1468           (if common-table-names ;otherwise: presentation-project is empty
1469               (query counting-selected-query :single!)
1470               0))
1471          (total-number-of-images
1472           (if common-table-names ;otherwise: presentation-project is empty
1473               (query counting-total-query :single!)
1474               0)))
1475     (save-dao (make-instance 'sys-selectable-restriction
1476                              :presentation-project-id presentation-project-id
1477                              :restriction-id tag :sql-clause sql-clause))
1478     (values
1479      (when old-selectable-restriction (sql-clause old-selectable-restriction))
1480      number-of-selected-images
1481      total-number-of-images)))
1482
1483 (defun* delete-image-attribute (presentation-project-name &mandatory-key tag)
1484   "Delete SQL expression stored with tag under
1485 presentation-project-name from current database.  Return the SQL
1486 expression deleted if there was any; return nil otherwise."
1487   (assert-phoros-db-major-version)
1488   (let ((selectable-restriction
1489          (get-dao 'sys-selectable-restriction
1490                   (presentation-project-id-from-name presentation-project-name)
1491                   tag)))
1492     (when selectable-restriction
1493       (delete-dao selectable-restriction)
1494       (sql-clause selectable-restriction))))
1495
1496 (defun* create-user (name &key
1497                           presentation-projects
1498                           &mandatory-key
1499                           user-password
1500                           user-full-name
1501                           user-role)
1502   "Create a fresh user entry or update an existing one with matching
1503 name.  Assign it presentation-projects, deleting any previously
1504 existing assignments."
1505   (assert-phoros-db-major-version)
1506   (assert (or (string-equal "read" user-role)
1507               (string-equal "write" user-role)
1508               (string-equal "admin" user-role))
1509           (user-role)
1510           "~A is not a valid user-role." user-role)
1511   (let ((user (or (car (select-dao 'sys-user (:= 'user-name name)))
1512                   (make-instance 'sys-user :user-name name)))
1513         fresh-user-p)
1514     (setf (user-password user) user-password
1515           (user-full-name user) user-full-name)
1516     (setf fresh-user-p (save-dao user))
1517     (mapcar #'delete-dao (select-dao 'sys-user-role
1518                                      (:= 'user-id (user-id user))))
1519     (dolist (presentation-project-name presentation-projects)
1520       (let ((presentation-project
1521              (get-dao 'sys-presentation-project presentation-project-name)))
1522         (if presentation-project
1523             (insert-dao
1524              (make-instance
1525               'sys-user-role
1526               :user-id (user-id user)
1527               :presentation-project-id
1528               (presentation-project-id presentation-project)
1529               :user-role (string-downcase user-role))) ;TODO: we should be able to set role per presentation-project.
1530             (warn
1531              "There is no presentation project ~A" presentation-project-name))))
1532     fresh-user-p))
1533
1534 (defun delete-user (user-name)
1535   "Delete user user-name if any; return nil if not."
1536   (assert-phoros-db-major-version)
1537   (let ((user (car (select-dao 'sys-user (:= 'user-name user-name)))))
1538     (when user (delete-dao user))))
1539
1540 (defun add-to-presentation-project (presentation-project-name
1541                                     &key measurement-ids acquisition-project)
1542   "Add to presentation project presentation-project-name either a list
1543 of measurements (with measurement-id) or all measurements currently in
1544 acquisition-project (denoted by its common-table-name)."
1545   (assert-phoros-db-major-version)
1546   (let* ((presentation-project
1547           (car (select-dao 'sys-presentation-project
1548                            (:= 'presentation-project-name
1549                                presentation-project-name))))
1550          (presentation-project-id
1551           (presentation-project-id presentation-project)))
1552     (flet ((add-measurement (measurement-id)
1553              "Add one measurement to the given presentation-project."
1554              (unless (get-dao 'sys-presentation
1555                               presentation-project-id
1556                               measurement-id)
1557                (insert-dao
1558                 (make-instance 'sys-presentation
1559                                :presentation-project-id presentation-project-id
1560                                :measurement-id measurement-id)))))
1561       (cond (measurement-ids (mapc #'add-measurement measurement-ids))
1562             (acquisition-project
1563              (dolist
1564                  (measurement-id
1565                    (query
1566                     (:select
1567                      'measurement-id
1568                      :from 'sys-measurement 'sys-acquisition-project
1569                      :where (:and
1570                              (:= 'sys-acquisition-project.common-table-name
1571                                  acquisition-project)
1572                              (:= 'sys-measurement.acquisition-project-id
1573                                  'sys-acquisition-project.acquisition-project-id)))
1574                     :column))
1575                (add-measurement measurement-id)))
1576             (t (error
1577                 "Don't know what to add.  ~
1578                  Need either measurement-id or acquisition-project."))))
1579     (let* ((common-table-names
1580             (common-table-names presentation-project-id))
1581            (presentation-project-bounding-box
1582             (ignore-errors             ;for empty presentation project
1583               (substitute
1584                #\, #\Space
1585                (string-trim
1586                 "BOX()"
1587                 (query
1588                  (sql-compile
1589                   `(:select
1590                     (:st_extent 'coordinates)
1591                     :from
1592                     (:as (:union
1593                           ,@(loop
1594                                for common-table-name in common-table-names
1595                                for point-table-name
1596                                = (point-data-table-name common-table-name)
1597                                ;; would have been nice, was too slow:
1598                                ;; = (aggregate-view-name common-table-name)
1599                                collect
1600                                `(:select
1601                                  'coordinates
1602                                  :from ',point-table-name
1603                                  :natural :left-join 'sys-presentation
1604                                  :where
1605                                  (:= 'presentation-project-id
1606                                      ,presentation-project-id))))
1607                          all-coordinates)))
1608                  :single!))))))
1609       (when presentation-project-bounding-box
1610         (setf (bounding-box presentation-project)
1611               presentation-project-bounding-box))
1612       (update-dao presentation-project))))
1613
1614 (defun remove-from-presentation-project (presentation-project-name
1615                                          &key measurement-ids acquisition-project)
1616   "Remove from presentation project presentation-project-name either a
1617 list of measurements (with measurement-id) or all measurements
1618 currently in acquisition-project with (denoted by its
1619 common-table-name).  Return nil if there weren't anything to remove."
1620   (assert-phoros-db-major-version)
1621   (let* ((presentation-project
1622           (car (select-dao 'sys-presentation-project
1623                            (:= 'presentation-project-name
1624                                presentation-project-name))))
1625          (presentation-project-id
1626           (Presentation-project-id presentation-project)))
1627     (flet ((remove-measurement (measurement-id)
1628              (let ((measurement
1629                     (car (select-dao
1630                           'sys-presentation
1631                           (:and (:= 'measurement-id measurement-id)
1632                                 (:= 'presentation-project-id
1633                                     presentation-project-id))))))
1634                (when measurement (delete-dao measurement)))))
1635     (cond (measurement-ids (mapc #'remove-measurement measurement-ids))
1636           (acquisition-project
1637            (dolist
1638                (measurement-id
1639                  (query
1640                   (:select
1641                    'measurement-id
1642                    :from 'sys-measurement 'sys-acquisition-project
1643                    :where (:and
1644                            (:= 'sys-acquisition-project.common-table-name
1645                                acquisition-project)
1646                            (:= 'sys-measurement.acquisition-project-id
1647                                'sys-acquisition-project.acquisition-project-id)))
1648                   :column))
1649              (remove-measurement measurement-id)))
1650           (t (error
1651               "Don't know what to remove.  ~
1652                Need either measurement-id or acquisition-project."))))))
1653
1654