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   (sql-compile
 127    `(:alter-table ,*table-name* :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-user-role ()
 153   ((user-id
 154     :initarg :user-id
 155     :col-type integer)
 156    (presentation-project-id
 157     :initarg :presentation-project-id
 158     :col-type integer)
 159    (user-role
 160     :initarg :user-role
 161     :col-type text
 162     :documentation "One of read, write, admin.")
 163    (bounding-box
 164     :col-type (or db-null text)
 165     :accessor bounding-box
 166     :documentation "Streetmap zoom extent last time user left Phoros.")
 167    (cursor
 168     :col-type (or db-null geometry)
 169     :accessor cursor
 170     :documentation "Point; users work coordinate in streetmap last time they left Phoros."))
 171   (:metaclass dao-class)
 172   (:keys user-id presentation-project-id))
 173
 174 (deftable sys-user-role
 175   (!dao-def)
 176   (!foreign 'sys-user 'user-id :on-delete :cascade :on-update :cascade)
 177   (!foreign 'sys-presentation-project 'presentation-project-id
 178             :on-delete :cascade :on-update :cascade))
 179
 180 (defclass sys-measurement ()
 181   ((measurement-id
 182     :reader measurement-id
 183     :col-type integer
 184     :col-default (:nextval 'sys-measurement-id-seq))
 185    (acquisition-project-id
 186     :initarg :acquisition-project-id
 187     :col-type integer)
 188    (directory
 189     :initarg :directory
 190     :col-type text
 191     :documentation
 192     "Below some universal root common to all measurements; excluding
 193 `applanix/´ `images/´ etc.
 194
 195 The entire directory structure looks like this:
 196
 197 Points
 198 ======
 199 /some/path/in/our/system/this/measurement/blah/applanix/points/xyz-event1.txt
 200 /some/path/in/our/system/this/measurement/blah/applanix/points/uvw-event2.txt
 201                                           ---- +++++++++++++++ ----+++++ ++++
 202 ^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^                               ^
 203     universal root       stored here in                                event
 204                          slot directory                                number
 205
 206 Images
 207 ======
 208 /some/path/in/our/system/this/measurement/blah/images/front77.pictures
 209 /some/path/in/our/system/this/measurement/blah/images/front78.pictures
 210                                           ---- ++++++         ++++++++
 211 ^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^             ^^^^^^^^^^^^^^^^
 212     universal root       stored here in               stored file name
 213                          slot directory
 214
 215 ++++ means constant
 216 ---- means unimportant
 217
 218 TODO: /images/ part not currently enforced.")
 219    (cartesian-system
 220     :initarg :cartesian-system
 221     :col-type text
 222     :documentation
 223     "Definition (as a Proj.4 string) of the coordinate system the recorded standard deviations are in."))
 224   (:metaclass dao-class)
 225   (:keys measurement-id)
 226   (:documentation "A measurement comprises .pictures files and one set of GPS event log files in a dedicated directory."))
 227
 228 (deftable sys-measurement
 229   (:create-sequence 'sys-measurement-id-seq)
 230   (!dao-def)
 231   (!index 'measurement-id)
 232   (!foreign 'sys-acquisition-project 'acquisition-project-id
 233             :on-delete :cascade :on-update :cascade))
 234
 235 (defclass sys-presentation ()
 236   ((presentation-project-id
 237     :initarg :presentation-project-id
 238     :col-type integer)
 239    (measurement-id
 240     :initarg :measurement-id
 241     :col-type integer))
 242   (:metaclass dao-class)
 243   (:keys presentation-project-id measurement-id)
 244   (:documentation "Tell us which measurements belong to which presentation project(s)."))
 245
 246 (deftable sys-presentation
 247   (!dao-def)
 248   (!index 'measurement-id)
 249   (!foreign 'sys-presentation-project 'presentation-project-id
 250             :on-delete :cascade :on-update :cascade)
 251   (!foreign 'sys-measurement 'measurement-id
 252             :on-delete :cascade :on-update :cascade))
 253
 254 (defclass sys-camera-hardware ()
 255   ((camera-hardware-id
 256     :reader camera-hardware-id
 257     :col-type integer
 258     :col-default (:nextval 'sys-camera-hardware-id-seq))
 259    (sensor-width-pix
 260     :col-type integer)
 261    (sensor-height-pix
 262     :col-type integer)
 263    (pix-size
 264     :col-type double-float)
 265    (channels
 266     :col-type integer)
 267    (pix-depth
 268     :col-type integer)
 269    (color-raiser
 270     :col-type float[]
 271     :documentation "Array of multipliers for red, green, blue.")
 272    (bayer-pattern
 273     :col-type integer[]
 274     :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.")
 275    (serial-number
 276     :col-type text)
 277    (description
 278     :col-type text
 279     :description "Camera type, manufacturer, etc."))
 280   (:metaclass dao-class)
 281   (:keys camera-hardware-id))
 282
 283 (deftable sys-camera-hardware
 284   (:create-sequence 'sys-camera-hardware-id-seq)
 285   (!dao-def)
 286   (!index 'camera-hardware-id))
 287
 288 (defclass sys-lens ()
 289   ((lens-id
 290     :reader lens-id
 291     :col-type integer
 292     :col-default (:nextval 'sys-lens-id-seq))
 293    (c
 294     :col-type double-float
 295     :documentation "Focal length.  Only for human consumption.")
 296    (serial-number
 297     :col-type text)
 298    (description
 299     :col-type text
 300     :documentation "Lens type, manufacturer, etc."))
 301   (:metaclass dao-class)
 302   (:keys lens-id))
 303
 304 (deftable sys-lens
 305   (:create-sequence 'sys-lens-id-seq)
 306   (!dao-def))
 307
 308 (defclass sys-generic-device ()
 309   ((generic-device-id
 310     :reader generic-device-id
 311     :col-type integer
 312     :col-default (:nextval 'sys-generic-device-id-seq))
 313    (camera-hardware-id
 314     :initarg :camera-hardware-id
 315     :col-type (or db-null integer))
 316    (lens-id
 317     :initarg :lens-id
 318     :col-type (or db-null integer))
 319    (scanner-id
 320     :initarg :scanner-id
 321     :col-type (or db-null integer)
 322     :documentation "Scanners yet to be defined."))
 323   (:metaclass dao-class)
 324   (:keys generic-device-id)
 325   (:documentation "A row should describe either a camera with a lens, or a laser scanner."))
 326
 327 (deftable sys-generic-device
 328   (:create-sequence 'sys-generic-device-id-seq)
 329   (!dao-def)
 330   (!index 'generic-device-id)
 331   (!index 'camera-hardware-id)
 332   (!foreign 'sys-camera-hardware 'camera-hardware-id
 333             :on-delete :restrict :on-update :restrict)
 334   (!foreign 'sys-lens 'lens-id :on-delete :restrict :on-update :restrict)
 335   ;;;; Once we have a sys-scanner table:
 336   ;;(!foreign 'sys-scanner 'scanner-id :on-delete :restrict :on-update :restrict)
 337   )
 338
 339 (defclass sys-device-stage-of-life ()
 340   ((device-stage-of-life-id
 341     :reader device-stage-of-life-id
 342     :col-type integer
 343     :col-default (:nextval 'sys-device-stage-of-life-seq))
 344    (recorded-device-id
 345     :col-type text
 346     :documentation "Must be stored next to each data record.  Example: in a .pictures file, this is the value of `cam=´.")
 347    (event-number
 348     :reader event-number
 349     :col-type text
 350     :documentation "Identifier for the GPS event that triggers this device.  Must correspond to the N the GPS file name: ...eventN.txt.")
 351    (generic-device-id
 352     :col-type integer)
 353    (vehicle-name
 354     :col-type text)
 355    (casing-name
 356     :col-type text
 357     :documentation "Something like `upper rear left´ or maybe `1.2.1´")
 358    (computer-name
 359     :col-type text
 360     :documentation "Computer (or or other recording device) this device is connected to.")
 361    (computer-interface-name
 362     :col-type text
 363     :documentation "Things like `eth0´, `COM1´ etc.")
 364    (mounting-date
 365     :col-type :timestamp-with-time-zone)
 366    (unmounting-date
 367     :col-type (or db-null :timestamp-with-time-zone)
 368     :documentation "Date and time when this device was unmounted or altered in other ways that may render the current calibration invalid."))
 369   (:metaclass dao-class)
 370   (:keys device-stage-of-life-id)
 371   (: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."))
 372
 373 (deftable sys-device-stage-of-life
 374   (:create-sequence 'sys-device-stage-of-life-seq)
 375   (!dao-def)
 376   (!index 'device-stage-of-life-id)
 377   (!index 'recorded-device-id)
 378   (!index 'mounting-date)
 379   (!index 'unmounting-date)
 380   (!foreign 'sys-generic-device 'generic-device-id
 381             :on-delete :restrict :on-update :restrict))
 382
 383 (defclass sys-camera-calibration ()
 384   ((device-stage-of-life-id
 385     :reader device-stage-of-life-id
 386     :col-type integer
 387     :documentation "This tells us what hardware this calibration is for.")
 388    (date
 389     :reader date
 390     :col-type :timestamp-with-time-zone)
 391    (person
 392     :col-type text)
 393    (main-description
 394     :col-type text
 395     :documentation "Regarding this entire set of calibration data.  Note the special-purpose description fields inner-orientation-description, outer-orientation-description, boresight-description.")
 396    (usable
 397     :col-type boolean
 398     :documentation "If false: just display images, don't perform photogrammetric calculations.")
 399    (debug
 400     :col-type boolean
 401     :documentation "If true: not for production use; may be altered or deleted at any time.")
 402    (photogrammetry-version
 403     :col-type text
 404     :documentation "Software version used to create this data.")
 405    (mounting-angle
 406     :col-type integer
 407     :documentation "Head up = 0; right ear up = 90; left ear up = -90; head down = 180.")
 408    (inner-orientation-description
 409     :col-type text
 410     :documentation "Comments regarding inner orientation calibration.")
 411    (c
 412     :col-type double-float
 413     :documentation "Inner orientation: focal length.")
 414    (xh
 415     :col-type double-float
 416     :documentation "Inner orientation: principal point displacement.")
 417    (yh
 418     :col-type double-float
 419     :documentation "Inner orientation: principal point displacement.")
 420    (a1
 421     :col-type double-float
 422     :documentation "Inner orientation: radial distortion.")
 423    (a2
 424     :col-type double-float
 425     :documentation "Inner orientation: radial distortion.")
 426    (a3
 427     :col-type double-float
 428     :documentation "Inner orientation: radial distortion.")
 429    (b1
 430     :col-type double-float
 431     :documentation "Inner orientation: asymmetric and tangential distortion.")
 432    (b2
 433     :col-type double-float
 434     :documentation "Inner orientation: asymmetric and tangential distortion.")
 435    (c1
 436     :col-type double-float
 437     :documentation "Inner orientation: affinity and shear distortion.")
 438    (c2
 439     :col-type double-float
 440     :documentation "Inner orientation: affinity and shear distortion.")
 441    (r0
 442     :col-type double-float
 443     :documentation "Inner orientation.")
 444    (outer-orientation-description
 445     :col-type text
 446     :documentation "Comments regarding outer orientation calibration.")
 447    (dx
 448     :col-type double-float
 449     :documentation "Outer orientation; in metres.")
 450    (dy
 451     :col-type double-float
 452     :documentation "Outer orientation; in metres.")
 453    (dz
 454     :col-type double-float
 455     :documentation "Outer orientation; in metres.")
 456    (omega
 457     :col-type double-float
 458     :documentation "Outer orientation.")
 459    (phi
 460     :col-type double-float
 461     :documentation "Outer orientation.")
 462    (kappa
 463     :col-type double-float
 464     :documentation "Outer orientation.")
 465    (boresight-description
 466     :col-type text
 467     :documentation "Comments regarding boresight alignment calibration.")
 468    (b-dx
 469     :col-type double-float
 470     :documentation "Boresight alignment.")
 471    (b-dy
 472     :col-type double-float
 473     :documentation "Boresight alignment.")
 474    (b-dz
 475     :col-type double-float
 476     :documentation "Boresight alignment.")
 477    (b-ddx
 478     :col-type double-float
 479     :documentation "Boresight alignment.")
 480    (b-ddy
 481     :col-type double-float
 482     :Documentation "Boresight alignment.")
 483    (b-ddz
 484     :col-type double-float
 485     :documentation "Boresight alignment.")
 486    (b-rotx
 487     :col-type double-float
 488     :documentation "Boresight alignment.")
 489    (b-roty
 490     :col-type double-float
 491     :documentation "Boresight alignment.")
 492    (b-rotz
 493     :col-type double-float
 494     :documentation "Boresight alignment.")
 495    (b-drotx
 496     :col-type double-float
 497     :documentation "Boresight alignment.")
 498    (b-droty
 499     :col-type double-float
 500     :documentation "Boresight alignment.")
 501    (b-drotz
 502     :col-type double-float
 503     :documentation "Boresight alignment.")
 504    (nx
 505     :col-type double-float
 506     :documentation "Component of unit vector of vehicle ground plane.")
 507    (ny
 508     :col-type double-float
 509     :documentation "Component of unit vector of vehicle ground plane.")
 510    (nz
 511     :col-type double-float
 512     :documentation "Component of unit vector of vehicle ground plane.")
 513    (d
 514     :col-type double-float
 515     :documentation "Distance of vehicle ground plane."))
 516   (:metaclass dao-class)
 517   (:keys device-stage-of-life-id date)
 518   (:documentation "Camera calibration parameters."))
 519
 520 (deftable sys-camera-calibration
 521   (!dao-def)
 522   (!index 'device-stage-of-life-id)
 523   (!index 'date)
 524   (!foreign 'sys-device-stage-of-life 'device-stage-of-life-id
 525             :on-delete :restrict :on-update :restrict))
 526
 527 (defun phoros-db-major-version ()
 528   "Get the version number of the database structure we are currently
 529 connected to.  It is supposed to be equal to the :major part of
 530 phoros-version."
 531   (query
 532    (:select 'last-value :from 'sys-phoros-major-version)
 533    :single!))
 534
 535 (defun (setf phoros-db-major-version) (major-version)
 536   "Set the version number of the database structure we are currently
 537 connected to. This can only be done once per database."
 538   (execute
 539    (:create-sequence 'sys-phoros-major-version
 540                      :min-value -1
 541                      :max-value major-version
 542                      :start major-version))
 543   (phoros-db-major-version))
 544
 545 (defun assert-phoros-db-major-version ()
 546   "Check if phoros version and version of the database we are
 547 connected to match."
 548   (assert (= (phoros-db-major-version) (phoros-version :major t)) ()
 549           "Can't use a Phoros database structure of version ~D.  ~
 550            It should be version ~D.  ~
 551            Either create a new database structure using this version of ~
 552            Phoros, or use Phoros version ~2:*~D.x.x."
 553           (phoros-db-major-version) (phoros-version :major t)))
 554
 555 (defun create-sys-tables ()
 556   "Create in current database a set of sys-* tables, i.e. tables that
 557 are used by all projects.  The database should probably be empty."
 558   (setf (phoros-db-major-version) (phoros-version :major t))
 559   (create-table 'sys-user)
 560   (create-table 'sys-acquisition-project)
 561   (create-table 'sys-presentation-project)
 562   (create-table 'sys-user-role)
 563   (create-table 'sys-measurement)
 564   (create-table 'sys-presentation)
 565   (create-table 'sys-camera-hardware)
 566   (create-table 'sys-lens)
 567   (create-table 'sys-generic-device)
 568   (create-table 'sys-device-stage-of-life)
 569   (create-table 'sys-camera-calibration)
 570   (create-plpgsql-helpers))
 571
 572 (defun create-plpgsql-helpers ()
 573   "Create in current database a few SQL types and functions."
 574   (execute
 575    (format nil "
 576 CREATE OR REPLACE
 577 FUNCTION bendedness
 578          (point1 GEOMETRY, point2 GEOMETRY, point3 GEOMETRY)
 579 RETURNS DOUBLE PRECISION AS $$
 580 -- Phoros version ~A
 581 BEGIN
 582   RETURN abs(st_azimuth(point2, point3) - st_azimuth(point1, point2));
 583 END;
 584 $$ LANGUAGE plpgsql;"
 585            (phoros-version)))
 586   (execute
 587    "DROP TYPE IF EXISTS point_bag;")
 588   (execute
 589    "CREATE TYPE point_bag AS (id int, coordinates GEOMETRY);"))
 590
 591 (defun !!index (table field &key (index-type :btree))
 592   (format nil "CREATE INDEX ~0@*~A_~1@*~A_index ON ~0@*~A USING ~2@*~A (~1@*~A)"
 593           (s-sql:to-sql-name table)
 594           (s-sql:to-sql-name field)
 595           (s-sql:to-sql-name index-type)))
 596
 597 (defclass point-template ()
 598   (;; We need a slot point-id which is defined in our subclasses.
 599    (random
 600     :col-type integer
 601     :initform (random (expt 2 31))
 602     :documentation "Used for quickly getting an evenly distributed sample of all points.")
 603    (measurement-id
 604     :writer (setf measurement-id)
 605     :col-type integer)
 606    (event-number
 607     :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.")
 608    (gps-time
 609     :reader gps-time
 610     :documentation "UTC calculated from GPS week time.")
 611    (trigger-time
 612     :writer (setf trigger-time)
 613     :col-type double-precision
 614     :documentation "Time in seconds from 1900.  Values before 1980-01-06T00:00:00Z are considered invalid.")
 615    (roll
 616     :col-type double-precision)
 617    (pitch
 618     :col-type double-precision)
 619    (heading
 620     :col-type double-precision)
 621    (east-velocity
 622     :col-type double-precision)
 623    (north-velocity
 624     :col-type double-precision)
 625    (up-velocity
 626     :col-type double-precision)
 627    (east-sd
 628     :col-type double-precision)
 629    (north-sd
 630     :col-type double-precision)
 631    (height-sd
 632     :col-type double-precision)
 633    (roll-sd
 634     :col-type double-precision)
 635    (pitch-sd
 636     :col-type double-precision)
 637    (heading-sd
 638     :col-type double-precision)
 639    (longitude
 640     :reader longitude
 641     :documentation "Same content as in slot coordinates.")
 642    (latitude
 643     :reader latitude
 644     :documentation "Same content as in slot coordinates.")
 645    (ellipsoid-height
 646     :reader ellipsoid-height
 647     :documentation "Same content as in slot coordinates.")
 648    (coordinates
 649     :col-type (or db-null geometry)
 650     :documentation "Geographic coordinates.")
 651    (easting
 652     :reader easting
 653     :documentation "In the same coordinate system as the standard deviations.")
 654    (northing
 655     :reader northing
 656     :documentation "In the same coordinate system as the standard deviations.")
 657    (cartesian-height
 658     :reader cartesian-height
 659     :documentation "In the same coordinate system as the standard deviations."))
 660   (:metaclass dao-class)
 661   (:keys point-id)
 662   (: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.  Perhaps we should create some cleaning operation to maintain referential integrity. (TODO)"))
 663
 664 (defclass image-template ()
 665   ((measurement-id
 666     :writer (setf measurement-id)
 667     :col-type integer
 668     :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.")
 669    (filename
 670     :reader filename
 671     :initarg :filename
 672     :col-type text
 673     :documentation "Name without any directory components.")
 674    (byte-position
 675     :reader image-byte-position
 676     :initarg :byte-position
 677     :col-type integer
 678     :documentation "Start of image in .pictures file named by slot filename.")
 679    (point-id
 680     :accessor point-id
 681     :col-type integer)
 682    (recorded-device-id
 683     :initarg :recorded-device-id
 684     :reader recorded-device-id
 685     :col-type text
 686     :documentation "As found in .pictures file, header tag `cam=´.")
 687    ;;(footprint
 688    ;; :col-type (or db-null geometry)
 689    ;; :documentation "Polygon on the ground describing the approximate area covered by this image.")
 690    (gain
 691     :initarg :gain
 692     :col-type double-precision
 693     :documentation "Camera parameter. TODO: needs a decent definition")
 694    (shutter
 695     :initarg :shutter
 696     :col-type double-precision
 697     :documentation "Camera parameter. TODO: needs a decent definition")
 698    (trigger-time
 699     :initarg :trigger-time
 700     :accessor trigger-time
 701     :documentation "Time in seconds from 1900-01-01.")
 702    (fake-trigger-time-p
 703     :accessor fake-trigger-time-p
 704     :initform nil
 705     :documentation "T if trigger-time has been reconstructed from adjacent data.")
 706    (camera-timestamp
 707     :initarg :camera-timestamp
 708     :reader camera-timestamp
 709     :documentation "Some camera clocktick count starting at an unknown origin."))
 710   (:metaclass dao-class)
 711   (:keys measurement-id filename byte-position)
 712   (:documentation "One row per image, originating from a .pictures file."))
 713
 714 (defclass user-point-template ()
 715   (;; We need a slot user-point-id which is defined in our subclasses.
 716    (user-id
 717     :initarg :user-id
 718     :col-type integer
 719     :documentation "User who stored this point.")
 720    (attribute
 721     :initarg :attribute
 722     :col-type text
 723     :documentation "Class of this user point.")
 724    (description
 725     :initarg :description
 726     :col-type text
 727     :documentation "User comment regarding this point.")
 728    (numeric-description
 729     :initarg :numeric-description
 730     :col-type text
 731     :documentation "User-generated point id regarding this point.")
 732    (creation-date
 733     :col-type :timestamp-with-time-zone
 734     :documentation "Creation time of this point.")
 735    (coordinates
 736     :col-type (or db-null geometry)
 737     :documentation "Geographic coordinates.")
 738    (stdx-global
 739     :initarg :stdx-global
 740     :col-type double-precision
 741     :documentation "Component of standard deviation, in metres.")
 742    (stdy-global
 743     :initarg :stdy-global
 744     :col-type double-precision
 745     :documentation "Component of standard deviation, in metres.")
 746    (stdz-global
 747     :initarg :stdz-global
 748     :col-type double-precision
 749     :documentation "Component of standard deviation, in metres.")
 750    (input-size
 751     :initarg :input-size
 752     :col-type integer
 753     :documentation "Number of points (from different images) used for calculation.")
 754    (aux-numeric
 755     :col-type (or db-null numeric[])
 756     :documentation "Arbitrary numeric values from auxiliary point table.")
 757    (aux-text
 758     :col-type (or db-null text[])
 759     :documentation "Arbitrary text values from auxiliary point table."))
 760   (:metaclass dao-class)
 761   (:keys user-point-id)
 762   (:documentation "Points defined by users."))
 763
 764 (defclass point-data (point-template)
 765   ((point-id
 766     :accessor point-id
 767     :initform nil
 768     :col-type integer
 769     :col-default nil)                   ;to be redefined
 770    point-id-sequence-name)              ;to be redefined
 771   (:metaclass dao-class)
 772   (:table-name nil))                    ;to be redefined
 773
 774 (defclass image-data (image-template)
 775   ()
 776   (:metaclass dao-class)
 777   (:table-name nil))                    ;to be redefined
 778
 779 (defclass user-point-data (user-point-template)
 780   ((user-point-id
 781     :accessor user-point-id
 782     :initform nil
 783     :col-type integer
 784     :col-default nil)                   ;to be redefined
 785    user-point-id-sequence-name)         ;to be redefined)
 786   (:metaclass dao-class)
 787   (:table-name nil))                    ;to be redefined
 788
 789 (let ((table-prefix "dat-"))
 790   (defun point-data-table-name (common-table-name)
 791     (make-symbol (format nil "~A~A-point"
 792                          table-prefix common-table-name)))
 793
 794   (defun image-data-table-name (common-table-name)
 795     (make-symbol (format nil "~A~A-image"
 796                          table-prefix common-table-name)))
 797
 798   (defun point-id-seq-name (common-table-name)
 799     (make-symbol (format nil "~A~A-point-id-seq"
 800                          table-prefix common-table-name)))
 801
 802   (defun aggregate-view-name (common-table-name)
 803     (make-symbol (format nil "~A~A-aggregate"
 804                          table-prefix common-table-name))))
 805
 806 (let ((table-prefix "usr-"))
 807   (defun user-point-table-name (presentation-project-name)
 808     (make-symbol (format nil "~A~A-point"
 809                          table-prefix presentation-project-name)))
 810
 811   (defun user-point-id-seq-name (presentation-project-name)
 812     (make-symbol (format nil "~A~A-point-id-seq"
 813                          table-prefix presentation-project-name)))
 814
 815   (defun user-line-table-name (presentation-project-name)
 816     (make-symbol (format nil "~A~A-line"
 817                          table-prefix presentation-project-name))))
 818
 819 (let ((table-prefix "phoros-"))
 820   ;; This stuff may reside in a foreign database so we show explicitly
 821   ;; what it belongs to.
 822   (defun aux-point-view-name (presentation-project-name)
 823     (make-symbol (format nil "~A~A-aux-point"
 824                          table-prefix presentation-project-name)))
 825
 826   (defun thread-aux-points-function-name (presentation-project-name)
 827     (make-symbol (format nil "~A~A-thread-aux-points"
 828                           table-prefix presentation-project-name))))
 829
 830 (defun create-data-table-definitions (common-table-name)
 831   "Define or redefine a bunch of dao-classes which can hold measuring
 832 data and which are connected to database tables named
 833 common-table-name plus type-specific prefix and suffix."
 834   (let ((image-data-table-name (image-data-table-name common-table-name))
 835         (point-data-table-name (point-data-table-name common-table-name))
 836         (point-id-sequence-name (point-id-seq-name common-table-name)))
 837     (eval
 838      `(defclass point-data (point-template)
 839         ((point-id
 840           :accessor point-id
 841           :initform nil
 842           :col-type integer
 843           :col-default (:nextval ,point-id-sequence-name)) ; redefinition
 844          (point-id-sequence-name
 845           :initform ,(string point-id-sequence-name) ; redefinition
 846           :reader point-id-sequence-name
 847           :allocation :class))
 848         (:metaclass dao-class)
 849         (:table-name ,point-data-table-name))) ;redefinition
 850     (deftable point-data
 851       (:create-sequence point-id-sequence-name)
 852       (!dao-def)
 853       (!!index point-data-table-name 'random)
 854       (!!index point-data-table-name 'measurement-id)
 855       (!!index point-data-table-name 'trigger-time)
 856       (!!index point-data-table-name 'coordinates :index-type :gist)
 857       (!!index point-data-table-name 'point-id)
 858       ;; The following let shouldn't be necessary. (Wart In !foreign.)
 859       (let ((*table-symbol* point-data-table-name)
 860             (*table-name*  (s-sql:to-sql-name point-data-table-name)))
 861         (!foreign 'sys-measurement 'measurement-id
 862                   :on-delete :cascade :on-update :cascade)))
 863     (eval
 864      `(defclass image-data (image-template)
 865         ()
 866         (:metaclass dao-class)
 867         (:table-name ,image-data-table-name))) ; redefintion
 868     (deftable image-data
 869       (!dao-def)
 870       (!!index image-data-table-name 'measurement-id)
 871       (!!index image-data-table-name 'recorded-device-id)
 872       (!!index image-data-table-name 'point-id)
 873       ;; (!!index image-data-table-name 'gain)
 874       ;; (!!index image-data-table-name 'shutter)
 875       ;;TODO: disabled as we don't have footprints: (!!index image-data-table-name 'footprint :index-type :gist)
 876       ;; The following let shouldn't be necessary. (Wart in !foreign.)
 877       (let ((*table-symbol* image-data-table-name)
 878             (*table-name*  (s-sql:to-sql-name image-data-table-name)))
 879         (!foreign point-data-table-name 'point-id
 880                   :on-delete :cascade :on-update :cascade)
 881         (!foreign 'sys-measurement 'measurement-id
 882                   :on-delete :cascade :on-update :cascade)))))
 883
 884 (defun create-user-table-definition (presentation-project-name)
 885   "Define or redefine a dao-class which can hold user points and which
 886 is connected to a database table named presentation-project-name plus
 887 type-specific prefix and suffix."
 888   (let ((user-point-table-name (user-point-table-name presentation-project-name))
 889         (user-point-id-sequence-name (user-point-id-seq-name presentation-project-name)))
 890     (eval
 891      `(defclass user-point (user-point-template)
 892         ((user-point-id
 893           :accessor point-id
 894           :initform nil
 895           :col-type integer
 896           :col-default (:nextval ,user-point-id-sequence-name))) ; redefinition
 897         (:metaclass dao-class)
 898         (:table-name ,user-point-table-name))) ;redefinition
 899     (deftable user-point
 900       (:create-sequence user-point-id-sequence-name)
 901       (!dao-def)
 902       (!!index user-point-table-name 'coordinates :index-type :gist))))
 903
 904 (defun create-aggregate-view (common-table-name)
 905   "Create a view of a set of measuring and calibration data
 906 belonging to images."
 907   (let ((image-data-table-name (image-data-table-name common-table-name))
 908         (point-data-table-name (point-data-table-name common-table-name))
 909         (aggregate-view-name (aggregate-view-name common-table-name)))
 910     (eval
 911      `(execute
 912        (:create-view
 913         ,aggregate-view-name
 914         (:select
 915          'sys-device-stage-of-life.recorded-device-id      ;debug
 916          'sys-device-stage-of-life.device-stage-of-life-id ;debug
 917          'sys-device-stage-of-life.generic-device-id       ;debug
 918          'random
 919          'presentation-project-id
 920          'directory
 921          'filename 'byte-position (:dot ',point-data-table-name 'point-id)
 922          'trigger-time
 923          'coordinates                   ;the search target
 924          (:as (:st_x (:st_transform 'coordinates *standard-coordinates*))
 925               'longitude)
 926          (:as (:st_y (:st_transform 'coordinates *standard-coordinates*))
 927               'latitude)
 928          (:as (:st_z (:st_transform 'coordinates *standard-coordinates*))
 929               'ellipsoid-height)
 930          'cartesian-system
 931          'east-sd 'north-sd 'height-sd
 932          'roll 'pitch 'heading 'roll-sd 'pitch-sd 'heading-sd
 933          'usable
 934          'sensor-width-pix 'sensor-height-pix 'pix-size
 935          'bayer-pattern 'color-raiser
 936          'mounting-angle
 937          'dx 'dy 'dz 'omega 'phi 'kappa
 938          'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
 939          'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
 940          'b-ddx 'b-ddy 'b-ddz 'b-drotx 'b-droty 'b-drotz
 941          :from
 942          'sys-measurement
 943          'sys-presentation
 944          ',point-data-table-name ',image-data-table-name
 945          'sys-device-stage-of-life 'sys-generic-device 'sys-camera-hardware
 946          'sys-camera-calibration
 947          :where
 948          (:and
 949           (:= (:dot ',image-data-table-name 'measurement-id)
 950               'sys-presentation.measurement-id)
 951           (:= 'sys-presentation.measurement-id
 952               'sys-measurement.measurement-id)
 953           (:= (:dot ',point-data-table-name 'point-id)
 954               (:dot ',image-data-table-name 'point-id))
 955           (:= (:dot ',image-data-table-name 'recorded-device-id)
 956               'sys-device-stage-of-life.recorded-device-id)
 957           (:= 'sys-generic-device.generic-device-id
 958               'sys-device-stage-of-life.generic-device-id)
 959           (:= 'sys-camera-hardware.camera-hardware-id
 960               'sys-generic-device.camera-hardware-id)
 961           (:= 'sys-device-stage-of-life.device-stage-of-life-id
 962               'sys-camera-calibration.device-stage-of-life-id)
 963           (:= 'sys-device-stage-of-life.device-stage-of-life-id
 964               (:limit
 965                (:order-by
 966                 (:select 'sys-camera-calibration.device-stage-of-life-id
 967                          :from 'sys-camera-calibration
 968                          :where
 969                          (:= 'sys-device-stage-of-life.device-stage-of-life-id
 970                              'sys-camera-calibration.device-stage-of-life-id))
 971                 (:desc 'date))
 972                1))
 973           (:<= (:extract :epoch 'sys-device-stage-of-life.mounting-date)
 974                (:- (:dot ',point-data-table-name 'trigger-time)
 975                    *unix-epoch*))
 976           (:or (:is-null 'sys-device-stage-of-life.unmounting-date)
 977                (:>= (:extract :epoch 'sys-device-stage-of-life.unmounting-date)
 978                     (:- (:dot ',point-data-table-name 'trigger-time)
 979                         *unix-epoch*))))))))
 980     ;;(eval
 981     ;; `(defclass ,aggregate-view-name (aggregate-data)
 982     ;;    ()
 983     ;;    (:metaclass dao-class)
 984     ;;    (:table-name ,aggregate-view-name))) ;redefinition
 985     ))
 986
 987 (defun aux-view-exists-p (presentation-project-name)
 988   "See if there is a view into auxiliary point table that belongs to
 989 presentation-project-name."
 990   (view-exists-p (aux-point-view-name presentation-project-name)))
 991
 992 (defun delete-aux-view (presentation-project-name)
 993   "Delete the view into auxiliary point table that belongs to
 994 presentation-project-name."
 995   (execute (format nil "DROP VIEW ~A CASCADE;"
 996                    (s-sql:to-sql-name (aux-point-view-name
 997                                        presentation-project-name))))
 998   (execute
 999    (format nil "DROP FUNCTION IF EXISTS ~
1000                 ~A(GEOMETRY, DOUBLE PRECISION, INT, DOUBLE PRECISION);"
1001            (s-sql:to-sql-name (thread-aux-points-function-name
1002                                presentation-project-name)))))
1003
1004 (defun* create-aux-view (presentation-project-name
1005                         &key (coordinates-column :the-geom)
1006                         numeric-columns text-columns
1007                         &mandatory-key aux-table)
1008   "Create a view into aux-table and an SQL function for threading
1009 aux-points into a linestring.  coordinates-column goes into column
1010 coordinates, numeric-columns and text-columns go into arrays in
1011 aux-numeric and aux-text respectively.
1012
1013 aux-table should have an index like so:
1014
1015 CREATE INDEX idx_<aux-table>_the_geom
1016   ON <aux-table>
1017   USING gist (the_geom);
1018
1019 VACUUM FULL ANALYZE <aux-table> (the_geom);"
1020   (create-plpgsql-helpers)
1021   (let ((aux-point-view-name
1022          (aux-point-view-name presentation-project-name))
1023         (thread-aux-points-function-name
1024          (thread-aux-points-function-name presentation-project-name)))
1025     (execute (format nil "
1026 CREATE VIEW ~A
1027 AS (SELECT ~A AS coordinates,
1028     ~:[NULL~;ARRAY[~:*~{~A~#^, ~}]~] AS aux_numeric,
1029     ~:[NULL~;ARRAY[~:*~{~A~#^, ~}]~] AS aux_text
1030     FROM ~A)"
1031                      (s-sql:to-sql-name aux-point-view-name)
1032                      coordinates-column
1033                      (mapcar #'s-sql:to-sql-name numeric-columns)
1034                      (mapcar #'s-sql:to-sql-name text-columns)
1035                      (s-sql:to-sql-name aux-table)))
1036     (execute (format nil "~
1037 CREATE OR REPLACE FUNCTION ~0@*~A
1038   (point GEOMETRY, sample_radius DOUBLE PRECISION, sample_size INT,
1039    step_size DOUBLE PRECISION, old_azimuth DOUBLE PRECISION,
1040    max_bend DOUBLE PRECISION,
1041    OUT threaded_points TEXT,
1042    OUT current_point TEXT,
1043    OUT back_point TEXT, OUT forward_point TEXT,
1044    OUT new_azimuth DOUBLE PRECISION)
1045 AS
1046 $$
1047 -- Phoros version ~2@*~A
1048 DECLARE
1049   point_bag_size INT;
1050   current_point_position DOUBLE PRECISION;
1051   location DOUBLE PRECISION;
1052   line GEOMETRY;
1053   new_point point_bag%ROWTYPE;
1054   tried_point point_bag%ROWTYPE;
1055   previous_point point_bag%ROWTYPE;
1056   starting_point GEOMETRY;
1057   reversal_count INT DEFAULT 0;
1058 BEGIN
1059   -- Muffle warnings about implicitly created stuff:
1060   SET client_min_messages TO ERROR;
1061
1062   starting_point :=
1063     (SELECT coordinates
1064        FROM ~1@*~A
1065        WHERE
1066          coordinates
1067          &&
1068          st_setsrid(st_makebox3d (st_translate (point,
1069                                                 - sample_radius * 5,
1070                                                 - sample_radius * 5, 0),
1071                                   st_translate (point,
1072                                                 sample_radius * 5,
1073                                                 sample_radius * 5, 0)),
1074                     4326)
1075        ORDER BY st_distance(coordinates, point)
1076        LIMIT 1);
1077
1078   CREATE TEMPORARY TABLE point_bag
1079     (id SERIAL primary key, coordinates GEOMETRY)
1080     ON COMMIT DROP;
1081
1082   INSERT INTO point_bag (coordinates)
1083     SELECT coordinates
1084       FROM ~1@*~A
1085
1086       WHERE
1087         coordinates
1088         &&
1089         st_setsrid(st_makebox3d (st_translate (starting_point,
1090                                                - sample_radius,
1091                                                - sample_radius, 0),
1092                                  st_translate (starting_point,
1093                                                sample_radius,
1094                                                sample_radius, 0)),
1095                    4326)
1096         AND st_distance (coordinates, starting_point) < sample_radius
1097       ORDER BY st_distance (coordinates, starting_point)
1098       LIMIT sample_size;
1099
1100   point_bag_size := (SELECT count(*) from point_bag);
1101
1102   -- emergency point_bag:
1103   IF point_bag_size < 5
1104   THEN
1105     DROP TABLE point_bag;
1106     CREATE TEMPORARY TABLE point_bag
1107       (id SERIAL primary key, coordinates GEOMETRY)
1108       ON COMMIT DROP;
1109     INSERT INTO point_bag (coordinates)
1110       SELECT coordinates
1111         FROM ~1@*~A
1112         WHERE
1113           coordinates
1114           &&
1115           st_setsrid(st_makebox3d (st_translate (point,
1116                                                  - sample_radius * 100,
1117                                                  - sample_radius * 100, 0),
1118                                    st_translate (point,
1119                                                  sample_radius * 100,
1120                                                  sample_radius * 100, 0)),
1121                      4326)
1122         ORDER BY st_distance (coordinates, starting_point)
1123         LIMIT 5;
1124     starting_point := (SELECT coordinates FROM point_bag where id = 3);
1125   END IF;
1126
1127   previous_point :=
1128     (SELECT ROW(id, coordinates)
1129        FROM point_bag
1130        ORDER BY st_distance (point_bag.coordinates, starting_point)
1131        LIMIT 1);
1132
1133   DELETE FROM point_bag WHERE id = previous_point.id;
1134
1135   new_point :=
1136     (SELECT ROW(id, coordinates)
1137        FROM point_bag
1138        ORDER BY st_distance (point_bag.coordinates, previous_point.coordinates)
1139        LIMIT 1);
1140
1141   line := st_makeline(previous_point.coordinates,
1142                       new_point.coordinates);
1143
1144   new_azimuth :=
1145     st_azimuth(previous_point.coordinates, new_point.coordinates);
1146
1147   IF abs(new_azimuth - old_azimuth) > radians(90)
1148      AND
1149      abs(new_azimuth - old_azimuth) < radians(270)
1150   THEN
1151     new_azimuth :=
1152       st_azimuth(new_point.coordinates, previous_point.coordinates);
1153     line := st_reverse(line);
1154   END IF;
1155
1156   DELETE FROM point_bag WHERE id = new_point.id;
1157
1158   LOOP
1159     previous_point.coordinates := st_pointn(line,1);
1160
1161     new_point :=
1162       (SELECT ROW(id, coordinates)
1163          FROM point_bag
1164          ORDER BY st_distance (coordinates, previous_point.coordinates)
1165          LIMIT 1);
1166
1167     EXIT WHEN new_point IS NULL;
1168
1169     IF bendedness(st_pointn(line, 2), st_pointn(line, 1),
1170                   new_point.coordinates)
1171        < bendedness(st_pointn(line, st_npoints(line) - 1),
1172                     st_pointn(line, st_npoints(line)), new_point.coordinates)
1173        AND
1174        bendedness(st_pointn(line, 2), st_pointn(line, 1),
1175                    new_point.coordinates)
1176        < max_bend
1177     THEN
1178         line := st_addpoint(line, new_point.coordinates, 0);
1179         DELETE FROM point_bag WHERE id = new_point.id;
1180     END IF;
1181
1182     line := st_reverse(line);
1183
1184     reversal_count := reversal_count + 1 ;
1185
1186     DELETE FROM point_bag WHERE id = tried_point.id;
1187
1188     tried_point := new_point;
1189   END LOOP;
1190
1191   IF mod(reversal_count, 2) = 1
1192   THEN
1193     line := st_reverse(line);
1194   END IF;
1195
1196   current_point_position :=
1197     st_line_locate_point(line, point);
1198
1199   current_point :=
1200     st_astext(st_line_interpolate_point(line, current_point_position));
1201
1202   location := (current_point_position - (step_size / st_length(line)));
1203   IF location < 0 THEN location := 0; END IF;
1204
1205   back_point :=
1206     st_astext(st_line_interpolate_point(line, location));
1207
1208   location := (current_point_position + (step_size / st_length(line)));
1209   IF location > 0 THEN location := 1; END IF;
1210
1211   forward_point :=
1212     st_astext(st_line_interpolate_point(line, location));
1213
1214   threaded_points := st_astext(line);
1215
1216   RETURN;
1217 END;
1218 $$ LANGUAGE plpgsql;"
1219                      (s-sql:to-sql-name thread-aux-points-function-name)
1220                      (s-sql:to-sql-name aux-point-view-name)
1221                      (phoros-version)))))
1222
1223 (defun create-acquisition-project (common-table-name)
1224   "Create in current database a fresh set of canonically named tables.
1225 common-table-name should in most cases resemble the project name and
1226 will be stored in table sys-acquisition-project, field
1227 common-table-name."
1228   (create-data-table-definitions common-table-name)
1229   (handler-case (create-sys-tables) ;Create system tables if necessary.
1230     (cl-postgres-error:syntax-error-or-access-violation () nil))
1231   (assert-phoros-db-major-version)
1232   (when (select-dao 'sys-acquisition-project
1233                     (:= 'common-table-name
1234                         (s-sql:to-sql-name common-table-name)))
1235     (error "There is already a row with a common-table-name of ~A in table ~A."
1236            common-table-name
1237            (s-sql:to-sql-name (dao-table-name 'sys-acquisition-project))))
1238   (create-table 'point-data)
1239   (create-table 'image-data)
1240   (create-aggregate-view common-table-name)
1241   (insert-dao
1242    (make-instance 'sys-acquisition-project
1243                   :common-table-name common-table-name)))
1244
1245 (defun delete-acquisition-project (common-table-name)
1246   "Delete the acquisition project that uses common-table-name.  Return
1247 nil if there wasn't any."
1248   (assert-phoros-db-major-version)
1249   (let ((project
1250          (car (select-dao 'sys-acquisition-project
1251                           (:= 'common-table-name common-table-name)))))
1252     (when project
1253       (delete-dao project)
1254       (execute (:drop-view
1255                 :if-exists (aggregate-view-name common-table-name)))
1256       (execute (:drop-table
1257                 :if-exists (image-data-table-name common-table-name)))
1258       (execute (:drop-table
1259                 :if-exists (point-data-table-name common-table-name)))
1260       (execute (:drop-sequence
1261                 :if-exists (point-id-seq-name common-table-name))))))
1262
1263 (defun delete-measurement (measurement-id)
1264   "Delete measurement with measurement-id if any; return nil if not."
1265   (assert-phoros-db-major-version)
1266   (let ((measurement (get-dao 'sys-measurement measurement-id)))
1267     (when measurement (delete-dao measurement))))
1268
1269 (defun create-presentation-project (project-name)
1270   "Create a fresh presentation project in current database.  Return
1271 dao if one was created, or nil if it existed already."
1272   (assert-phoros-db-major-version)
1273   (unless (get-dao 'sys-presentation-project project-name)
1274     (create-user-table-definition project-name)
1275     (create-table 'user-point)
1276     (create-presentation-project-trigger-function project-name)
1277     (execute (format nil "DROP TRIGGER IF EXISTS ~A ON ~:*~A;"
1278                      (s-sql:to-sql-name (user-point-table-name project-name))))
1279     (execute (format nil "
1280 CREATE TRIGGER ~A
1281   AFTER INSERT OR UPDATE OR DELETE
1282   ON ~:*~A
1283   FOR EACH ROW EXECUTE PROCEDURE ~:*~A();"
1284                      (s-sql:to-sql-name (user-point-table-name project-name))))
1285     (execute (sql-compile
1286               `(:create-table ,(user-line-table-name project-name)
1287                               ((description :type text)
1288                                ;; description would be a nice primary
1289                                ;; key if it wasn't for QGIS which
1290                                ;; needs it numeric
1291                                (id :type serial :primary-key t)
1292                                (line :type geometry)))))
1293     (insert-dao (make-instance 'sys-presentation-project
1294                                :presentation-project-name project-name))))
1295
1296 (defun create-presentation-project-trigger-function
1297     (presentation-project
1298      &optional (plpgsql-body
1299                 (format
1300                  nil "  RAISE NOTICE 'trigger fired: ~A';"
1301                  (s-sql:to-sql-name (user-point-table-name
1302                                      presentation-project))))
1303      &rest plpgsql-body-args)
1304   "(Re)create in current database an SQL trigger function with
1305 plpgsql-body (a format string that uses plpgsql-body-args)."
1306   (execute (format
1307             nil "
1308 CREATE OR REPLACE FUNCTION ~A() RETURNS trigger
1309 AS
1310 $$
1311 BEGIN
1312   ------------------------------------------
1313   -- Define your trigger actions below:
1314   ------------------------------------------
1315 ~?~&~:
1316   ------------------------------------------
1317   -- End of your trigger action definitions.
1318   ------------------------------------------
1319   RETURN NULL;
1320 END;
1321 $$ LANGUAGE plpgsql;"
1322             (s-sql:to-sql-name (user-point-table-name presentation-project))
1323             plpgsql-body
1324             plpgsql-body-args)))
1325
1326 (defun fire-presentation-project-trigger-function (presentation-project)
1327   "Tickle user point table of presentation-project so it fires its
1328 trigger."
1329   (let ((user-point-table (user-point-table-name presentation-project)))
1330     (execute
1331      (:update user-point-table
1332               :set 'user-point-id 'user-point-id
1333               :where (:= 'user-point-id
1334                          (:limit (:select 'user-point-id
1335                                           :from user-point-table) 1))))))
1336
1337 (defun delete-presentation-project (project-name)
1338   "Delete the presentation project project-name.  Return nil if there
1339 wasn't any."
1340   (assert-phoros-db-major-version)
1341   (let ((project (get-dao 'sys-presentation-project project-name)))
1342     (when project
1343       (delete-dao project)
1344       (execute
1345        (:drop-table :if-exists (user-point-table-name project-name)))
1346       (execute
1347        (:drop-sequence :if-exists (user-point-id-seq-name project-name)))
1348       (execute
1349        (:drop-table :if-exists (user-line-table-name project-name))))))
1350
1351 (defun* create-user (name &key
1352                           presentation-projects
1353                           &mandatory-key
1354                           user-password
1355                           user-full-name
1356                           user-role)
1357   "Create a fresh user entry or update an existing one with matching
1358 name.  Assign it presentation-projects, deleting any previously
1359 existing assignments."
1360   (assert-phoros-db-major-version)
1361   (assert (or (string-equal "read" user-role)
1362               (string-equal "write" user-role)
1363               (string-equal "admin" user-role))
1364           (user-role)
1365           "~A is not a valid user-role." user-role)
1366   (let ((user (or (car (select-dao 'sys-user (:= 'user-name name)))
1367                   (make-instance 'sys-user :user-name name)))
1368         fresh-user-p)
1369     (setf (user-password user) user-password
1370           (user-full-name user) user-full-name)
1371     (setf fresh-user-p (save-dao user))
1372     (mapcar #'delete-dao (select-dao 'sys-user-role
1373                                      (:= 'user-id (user-id user))))
1374     (dolist (presentation-project-name presentation-projects)
1375       (let ((presentation-project
1376              (get-dao 'sys-presentation-project presentation-project-name)))
1377         (if presentation-project
1378             (insert-dao
1379              (make-instance
1380               'sys-user-role
1381               :user-id (user-id user)
1382               :presentation-project-id
1383               (presentation-project-id presentation-project)
1384               :user-role (string-downcase user-role))) ;TODO: we should be able to set role per presentation-project.
1385             (warn
1386              "There is no presentation project ~A" presentation-project-name))))
1387     fresh-user-p))
1388
1389 (defun delete-user (user-name)
1390   "Delete user user-name if any; return nil if not."
1391   (assert-phoros-db-major-version)
1392   (let ((user (car (select-dao 'sys-user (:= 'user-name user-name)))))
1393     (when user (delete-dao user))))
1394
1395 (defun add-to-presentation-project (presentation-project-name
1396                                     &key measurement-ids acquisition-project)
1397   "Add to presentation project presentation-project-name either a list
1398 of measurements (with measurement-id) or all measurements currently in
1399 acquisition-project (denoted by its common-table-name)."
1400   (assert-phoros-db-major-version)
1401   (let* ((presentation-project
1402           (car (select-dao 'sys-presentation-project
1403                            (:= 'presentation-project-name
1404                                presentation-project-name))))
1405          (presentation-project-id
1406           (presentation-project-id presentation-project)))
1407     (flet ((add-measurement (measurement-id)
1408              "Add one measurement to the given presentation-project."
1409              (unless (get-dao 'sys-presentation
1410                               presentation-project-id
1411                               measurement-id)
1412                (insert-dao
1413                 (make-instance 'sys-presentation
1414                                :presentation-project-id presentation-project-id
1415                                :measurement-id measurement-id)))))
1416       (cond (measurement-ids (mapc #'add-measurement measurement-ids))
1417             (acquisition-project
1418              (dolist
1419                  (measurement-id
1420                    (query
1421                     (:select
1422                      'measurement-id
1423                      :from 'sys-measurement 'sys-acquisition-project
1424                      :where (:and
1425                              (:= 'sys-acquisition-project.common-table-name
1426                                  acquisition-project)
1427                              (:= 'sys-measurement.acquisition-project-id
1428                                  'sys-acquisition-project.acquisition-project-id)))
1429                     :column))
1430                (add-measurement measurement-id)))
1431             (t (error
1432                 "Don't know what to add.  ~
1433                  Need either measurement-id or acquisition-project."))))
1434     (let* ((common-table-names
1435             (common-table-names presentation-project-id))
1436            (presentation-project-bounding-box
1437             (ignore-errors             ;for empty presentation project
1438               (substitute
1439                #\, #\Space
1440                (string-trim
1441                 "BOX()"
1442                 (query
1443                  (sql-compile
1444                   `(:select
1445                     (:st_extent 'coordinates)
1446                     :from
1447                     (:as (:union
1448                           ,@(loop
1449                                for common-table-name in common-table-names
1450                                for point-table-name
1451                                = (point-data-table-name common-table-name)
1452                                ;; would have been nice, was too slow:
1453                                ;; = (aggregate-view-name common-table-name)
1454                                collect
1455                                `(:select
1456                                  'coordinates
1457                                  :from ',point-table-name
1458                                  :natural :left-join 'sys-presentation
1459                                  :where
1460                                  (:= 'presentation-project-id
1461                                      ,presentation-project-id))))
1462                          all-coordinates)))
1463                  :single!))))))
1464       (when presentation-project-bounding-box
1465         (setf (bounding-box presentation-project)
1466               presentation-project-bounding-box))
1467       (update-dao presentation-project))))
1468
1469 (defun remove-from-presentation-project (presentation-project-name
1470                                          &key measurement-ids acquisition-project)
1471   "Remove from presentation project presentation-project-name either a
1472 list of measurements (with measurement-id) or all measurements
1473 currently in acquisition-project with (denoted by its
1474 common-table-name).  Return nil if there weren't anything to remove."
1475   (assert-phoros-db-major-version)
1476   (let* ((presentation-project
1477           (car (select-dao 'sys-presentation-project
1478                            (:= 'presentation-project-name
1479                                presentation-project-name))))
1480          (presentation-project-id
1481           (Presentation-project-id presentation-project)))
1482     (flet ((remove-measurement (measurement-id)
1483              (let ((measurement
1484                     (car (select-dao
1485                           'sys-presentation
1486                           (:and (:= 'measurement-id measurement-id)
1487                                 (:= 'presentation-project-id
1488                                     presentation-project-id))))))
1489                (when measurement (delete-dao measurement)))))
1490     (cond (measurement-ids (mapc #'remove-measurement measurement-ids))
1491           (acquisition-project
1492            (dolist
1493                (measurement-id
1494                  (query
1495                   (:select
1496                    'measurement-id
1497                    :from 'sys-measurement 'sys-acquisition-project
1498                    :where (:and
1499                            (:= 'sys-acquisition-project.common-table-name
1500                                acquisition-project)
1501                            (:= 'sys-measurement.acquisition-project-id
1502                                'sys-acquisition-project.acquisition-project-id)))
1503                   :column))
1504              (remove-measurement measurement-id)))
1505           (t (error
1506               "Don't know what to remove.  ~
1507                Need either measurement-id or acquisition-project."))))))
1508
1509