Coverage report: /development/source/library/org/datagraph/spocq-shard/src/core/temporal-data.lisp

Kind	Covered	All	%
expression	2326	3937	59.1
branch	139	250	55.6

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.datagraph.spocq.implementation; -*-

2

3

(in-package :org.datagraph.spocq.implementation)

4

5

6

(:documentation "temporal data-types"

7

   "Temporal data is modeled as distinct structure classes, one for each of the xsd data types. (see terms.lisp)

8

The abstract field capture an atomic value to be used in operations.

9

The concrete classes define fields for components of the lexical form, to serve as intermediaries

10

when parsing and encoding lexical forms.

11

12

nb. fragment type constraints are enforced at the strucure leve based on the slot type declarations.

13

further constraints, such a that between initialized and uninitialized slots, are handed locally.

14

15

  nb. the timeline computation for negative durations is not the same as that for negative date/datetime/time

16

values with respect to the fragment magnitudes.

17

in the duration case, negative components accumulate, but i the datetime case, the year only

18

is negative. this means that the sign on the individual componnt must be retained.

19

20

nb. date and date-time are distinct:

21

- http://www.w3.org/TR/xmlschema-2/#built-in-datatypes

22

- http://www.w3.org/TR/xmlschema11-2/#built-in-datatypes

23

24

nb. on the practice of dates without time zones:

25

as to UTC as the default zone : http://www.w3.org/TR/2005/NOTE-timezone-20051013/#d2e448

26

27

The construction protocol proceeds as

28

parse -> (normalize | constrain) -> canonicalize -> instantiate

29

in various operators, each of which covers different aspects

30

31

make- : normalize -> canonicalize -> instantiate

32

encode- : normalize -> canonicalize -> instantiate

33

parse- : parse

34

|-xxx-| (string) : parse -> constrain -> canonicalize -> instantiate

35

|-xxx-| (instance) : de-canonicalize -> format

36

decode (string) : parse -> constrain -> canonicalize

37

decode (instance) : identity + zone

38

39

encode- and make- operators both normalize, neither constrains.

40

  the distinction is that the make- variation expects type-specific frgaments while the encode- variation accepts the full complement.

41

42

checking conversions: https://dencode.com/en/date/iso8601

43

")

44

45

;; (dydra-ndk:encode-time )

46

;; (dydra-ndk:decode-time )

47

48

(defconstant +timeline-units-per-second+ 1000000)

49

(defconstant +timeline-months-per-year+ 12)

50

(defconstant +timeline-minutes-per-hour+ 60)

51

(defconstant +timeline-seconds-per-minute+ 60)

52

(defconstant +timeline-seconds-per-hour+ (* +timeline-seconds-per-minute+ +timeline-minutes-per-hour+))

53

(defconstant +timeline-hours-per-day+ 24)

54

(defconstant +timeline-seconds-per-day+ (* +timeline-seconds-per-hour+ +timeline-hours-per-day+))

55

(defconstant +timeline-units-per-day+ (* +timeline-seconds-per-day+ 1000000))

56

(defconstant +timeline-universal-time-epoch-day+ 1)

57

(defconstant +timeline-universal-time-epoch-month+ 1)

58

(defconstant +timeline-universal-time-epoch-year+ 1970)

59

(defconstant +timeline-universal-time-epoch+ #.(encode-universal-time 0 0 0 1 1 1970 0))

60

61

62

(defun timeline-location-fraction (location)

63

(nth-value 0 (dydra-ndk:decode-time location spocq:+reference-zone+)))

64

(defun timeline-location-second (location)

65

(nth-value 1 (dydra-ndk:decode-time location spocq:+reference-zone+)))

66

(defun timeline-location-minute (location)

67

(nth-value 2 (dydra-ndk:decode-time location spocq:+reference-zone+)))

68

(defun timeline-location-hour (location)

69

(nth-value 3 (dydra-ndk:decode-time location spocq:+reference-zone+)))

70

(defun timeline-location-day (location)

71

(nth-value 4 (dydra-ndk:decode-time location spocq:+reference-zone+)))

72

(defun timeline-location-month (location)

73

(nth-value 5 (dydra-ndk:decode-time location spocq:+reference-zone+)))

74

(defun timeline-location-year (location)

75

(nth-value 6 (dydra-ndk:decode-time location spocq:+reference-zone+)))

76

77

(defun get-timeline-location ()

78

(multiple-value-bind (s mus) (OSICAT-POSIX:GETTIMEOFDAY)

79

(+ mus (* s 1000000))))

80

81

82

;; internal operators

83

84

(defgeneric temporal-decoded-p (term)

85

(:documentation "return true if the temporal facets have been decoded.

86

Each class tests a specific facet."))

87

88

(defgeneric duration-second-location (duration)

89

(:documentation "Given a duration, return the second location.

90

For a day-time-duration, generate it if necessary form the facets.

91

For other durations, the value is constantly zero"))

92

93

(defgeneric duration-month-location (duration)

94

(:documentation "Given a duration, return the second location.

95

For a year-month-duration, generate it if necessary form the facets.

96

For other durations, the value is constantly zero"))

97

98

(defun zones-comparable-p (z1 z2)

99

(when (or (and z1 z2)

100

(not (or z1 z2)))

101

t))

102

103

(defmacro constrain-temporal-fragments ((&rest fragments) type)

104

`(progn

105

,@(loop for fragment in fragments

106

collect (ecase fragment

107

                        (fraction `(assert-argument-type ,type fraction (integer -999999 999999)))

108

(second `(assert-argument-type ,type second (integer -59 59)))

109

(minute `(assert-argument-type ,type minute (integer -59 59)))

110

(hour `(assert-argument-type ,type hour (integer -24 24)))

111

(day (case type

112

((|xsd|:|date| |xsd|:|dateTime|)

113

                                `(unless (and (> day 0) (<= day (date:month-days month year)))

114

                                   (invalid-argument-type ,type day |xsd|:|gDay|)))

115

(t

116

`(assert-argument-type ,type day ,(ecase type

117

                                                                    ((|xsd|:|dayTimeDuration| |xsd|:|duration|) 'integer)

118

                                                                    ((|xsd|:|gDay| |xsd|:|gMonth| |xsd|:|gMonthDay|

119

                                                                                   |xsd|:|gYearMonth| |xsd|:|gYear|) '(integer 1 31)))))))

120

(month `(assert-argument-type ,type month ,(ecase type

121

                                                                     ((|xsd|:|yearMonthDuration| |xsd|:|duration|) 'integer)

122

                                                                     ((|xsd|:|gDay| |xsd|:|gMonth| |xsd|:|gMonthDay|

123

                                                                                     |xsd|:|gYearMonth| |xsd|:|gYear|

124

                                                                                     |xsd|:|date| |xsd|:|dateTime|) '(integer 1 12)))))

125

(year (ecase type

126

                                ((|xsd|:|gDay| |xsd|:|gMonth|  |xsd|:|gMonthDay| |xsd|:|gYear| |xsd|:|gYearMonth|) `(assert-argument-type ,type year (integer 0)))

127

                                ((|xsd|:|yearMonthDuration| |xsd|:|date| |xsd|:|dateTime|  |xsd|:|duration|) `(assert-argument-type ,type year integer))))

128

                        (zone `(assert-argument-type ,type zone (or null spocq:zone-fragment)))))

129

(values ,@fragments)))

130

131

132

(defun compute-duration-locations (fraction second minute hour day month year)

133

"Compute the uniform pair of uniform locations given duration fragments.

134

Yields two values: the combined months and the combined microseconds."

135

136

(values (+ month

137

(* +timeline-months-per-year+ year))

138

(+ fraction

139

(* +timeline-units-per-second+ second)

140

(* (* +timeline-units-per-second+ +timeline-seconds-per-minute+) minute)

141

(* (* +timeline-seconds-per-hour+ +timeline-units-per-second+) hour)

142

(* (* +timeline-seconds-per-day+ +timeline-units-per-second+) day))))

143

;;; (compute-duration-locations 1 1 1 1 1 0 0)

144

;;; (compute-duration-locations 0 0 0 0 0 1 1)

145

146

147

(defun compute-duration-fragments (month-location time-location)

148

"Given the duration uniform location pair, compute the respective fragments and.

149

Yields the values: units, seconds, minutes, hours, days, months and years."

150

151

(if (zerop time-location)

152

(if (zerop month-location)

153

(values 0 0 0 0 0 0 0)

154

(multiple-value-bind (years months) (truncate month-location +timeline-months-per-year+)

155

(values 0 0 0 0 0 months years)))

156

(multiple-value-bind (rest units) (truncate time-location +timeline-units-per-second+)

157

(multiple-value-bind (rest seconds) (truncate rest +timeline-seconds-per-minute+)

158

(multiple-value-bind (rest minutes) (truncate rest +timeline-minutes-per-hour+)

159

(multiple-value-bind (days hours) (truncate rest +timeline-hours-per-day+)

160

(if (zerop month-location)

161

(values units seconds minutes hours days 0 0)

162

               (multiple-value-bind (years months) (truncate month-location +timeline-months-per-year+)

163

(values units seconds minutes hours days months years)))))))))

164

165

166

(defgeneric decode-zone-offset (zone-offset)

167

   (:documentation "Given a zone offset as a real hour value return the integer hour and minute values.

168

For a negative offset, both values are negative, as for a duration.")

169

(:method ((zone-offset real))

170

(multiple-value-bind (hours fraction) (truncate zone-offset)

171

(values hours (* fraction 60))))

172

(:method ((zone-offset integer))

173

(truncate zone-offset 60)))

174

175

176

(defgeneric spocq:format-zone-offset (stream zone-offset &optional expand-zulu-p arg)

177

(:method (stream (zone-offset null) &optional (expand-zulu-p nil) arg)

178

(declare (ignore expand-zulu-p arg))

179

zone-offset)

180

(:method (stream (zone-offset real) &optional (expand-zulu-p nil) arg)

181

(declare (ignore arg))

182

(if (and (zerop zone-offset) (not expand-zulu-p))

183

(write-char #\Z stream)

184

(multiple-value-bind (hours minutes) (decode-zone-offset zone-offset)

185

(format stream "~:[+~;-~]~2,'0d:~2,'0d"

186

(minusp hours)

187

(abs hours)

188

(abs minutes))))))

189

190

;;; (spocq:format-zone-offset t 63/15)

191

;;; (spocq:format-zone-offset t -63/15)

192

;;; (spocq:format-zone-offset t 253)

193

;;; (spocq:format-zone-offset t -253)

194

195

(defun offset-zone-p (zone)

196

(and zone (not (zerop zone))))

197

198

(defun universal-time-timeline-location (value)

199

(* (- value +timeline-universal-time-epoch+) +timeline-units-per-second+))

200

201

(defun timeline-location-universal-time (value)

202

(+ (floor value +timeline-units-per-second+) +timeline-universal-time-epoch+))

203

204

205

;;; normalization takes two forms, of which each requires a different .div. implementation

206

;;; - for locations, the fragment values must be positive -- .div./.mod. are floor

207

;;; - for durations, both positiive and negative fragments are permitted -- .div./.mod. are truncate

208

;;; the individual steps are coded as macros to side-effect the existing bindings

209

210

211

(defmacro normalize-location-fraction-second-to-minute (fraction second minute)

212

   "Generate forms for location temporal fragments fraction, second and minute, to normalize from the second and

213

propagate any change to the minute. For a location, the results must be positive.

214

(see http://www.w3.org/TR/xmlschema11-2/#f-dt-normSe)"

215

`(progn

216

(unless (<= 0 ,fraction (1- +timeline-units-per-second+))

217

(multiple-value-bind (s f) (floor ,fraction +timeline-units-per-second+)

218

(setf ,fraction f)

219

(incf ,second s)))

220

(unless (<= 0 ,second (1- +timeline-seconds-per-minute+))

221

(multiple-value-bind (m s) (floor ,second +timeline-seconds-per-minute+)

222

(setf ,second s)

223

(incf ,minute m)))))

224

225

(defmacro normalize-duration-fraction-second-to-minute (fraction second minute)

226

   "Generate forms for duration temporal fragments fraction, second and minute, to normalize from the second and

227

propagate any change to the minute. For a duration, the results may be positive or negative.

228

(see http://www.w3.org/TR/xmlschema11-2/#f-dt-normSe)"

229

`(progn

230

(unless (and (< +timeline-units-per-second+ ,fraction) (< ,fraction +timeline-units-per-second+))

231

(multiple-value-bind (s f) (truncate ,fraction +timeline-units-per-second+)

232

(setf ,fraction f)

233

(incf ,second s)))

234

(unless (and (< +timeline-seconds-per-minute+ ,second)

235

(< ,second +timeline-seconds-per-minute+))

236

(multiple-value-bind (m s) (truncate ,second +timeline-seconds-per-minute+)

237

(setf ,second s)

238

(incf ,minute m)))))

239

240

241

(defmacro normalize-location-minute-to-hour (minute hour)

242

"Generate forms for temporal fragments minute and hour, to normalize the minute and

243

propagate any change to the hour. For a location, the results must be positive.

244

(see http://www.w3.org/TR/xmlschema11-2/#f-dt-normMi)"

245

`(unless (<= 0 ,minute (1- +timeline-minutes-per-hour+))

246

(multiple-value-bind (h m) (floor ,minute +timeline-minutes-per-hour+)

247

(setf ,minute m)

248

(incf ,hour h))))

249

250

(defmacro normalize-duration-minute-to-hour (minute hour)

251

"Generate forms for temporal fragments minute and hour, to normalize the minute and

252

propagate any change to the hour. For a location, the may be positive or negative.

253

(see http://www.w3.org/TR/xmlschema11-2/#f-dt-normMi)"

254

`(unless (and (< +timeline-minutes-per-hour+ ,minute)

255

(< ,minute +timeline-minutes-per-hour+))

256

(multiple-value-bind (h m) (truncate ,minute +timeline-minutes-per-hour+)

257

(setf ,minute m)

258

(incf ,hour h))))

259

260

261

(defmacro normalize-location-hour-to-day (hour day)

262

"Generate forms for temporal fragments hour and day, to normalize the hour and

263

propagate any change to the day. For a location, the results must be positive.

264

(see http://www.w3.org/TR/xmlschema11-2/#f-dt-normHo)"

265

`(unless (<= 0 ,hour (1- +timeline-hours-per-day+))

266

(multiple-value-bind (d h) (floor ,hour +timeline-hours-per-day+)

267

(setf ,hour h)

268

(incf ,day d))))

269

270

(defmacro normalize-duration-hour-to-day (hour day)

271

"Generate forms for temporal fragments hour and day, to normalize the hour and

272

propagate any change to the day. For a location, the results must be positive.

273

(see http://www.w3.org/TR/xmlschema11-2/#f-dt-normHo)"

274

`(unless (and (< +timeline-hours-per-day+ ,hour)

275

(< ,hour +timeline-hours-per-day+))

276

(multiple-value-bind (d h) (truncate ,hour +timeline-hours-per-day+)

277

(setf ,hour h)

278

(incf ,day d))))

279

280

281

(defmacro normalize-location-month-to-year (month year)

282

   "for a date-time value, given a month and a year, normalize the month value to reflect a legal month and

283

adjust the year accordingly. negative months - from a combination with a duration, reduce the years

284

(see http://www.w3.org/TR/xmlschema11-2/#sec-normalization)"

285

`(unless (<= 1 ,month +timeline-months-per-year+)

286

(let ((.month. (1- ,month)))

287

(incf ,year (floor .month. +timeline-months-per-year+))

288

(setf ,month (1+ (mod .month. +timeline-months-per-year+))))))

289

 ;;; (loop for i from -13 to 13 collect (let ((month i) (year 1900)) (normalize-location-month-year month year) (list i month year)))

290

291

(defmacro normalize-duration-month-to-year (month year)

292

;; nb. this is not date-time normalization, as that treats negative months differently

293

`(unless (and (< (- +timeline-months-per-year+) ,month)

294

(< ,month +timeline-months-per-year+))

295

(multiple-value-bind (y m) (truncate ,month +timeline-months-per-year+)

296

(setf ,month m)

297

(incf ,year y))))

298

299

300

(defmacro normalize-location-day-month-to-year (day month year)

301

"Given the temporal fragments from day to year, normalize the day respective to the

302

month and year and propagate any change all the way through.

303

nb. this permits non-positive values, as per http://www.w3.org/TR/xmlschema11-2/#f-dt-normDa"

304

`(progn

305

(normalize-location-month-to-year ,month ,year)

306

(let ((day-limit (date:month-days ,month ,year)))

307

(loop (cond ((<= ,day 0)

308

(decf ,month)

309

(normalize-location-month-to-year ,month ,year)

310

(setf day-limit (date:month-days ,month ,year))

311

(incf ,day day-limit))

312

((> ,day day-limit)

313

(decf ,day day-limit)

314

(incf ,month)

315

(normalize-location-month-to-year ,month ,year)

316

(setf day-limit (date:month-days ,month ,year)))

317

(t

318

(return)))))))

319

320

321

322

;;; constructors exists in two forms. the make- forms have signatures is specific to the type

323

;;; but constrain argument values, only in that they must be fixnum and normalize the actual

324

;;; arguments to conform to the respective temporal type.

325

;;; the encode- forms all have the same signature, as they are intended

326

;;; to be used abstractly and then delegate to the type-specific operator for the actual construction

327

;;; temporal value, for which reason thay constrain fragment values, normalize

328

;;; them, and canonicalize to utc.

329

;;;

330

;;; n.b. the parameter order corresponds to that of the standard universal time operators,

331

;;; even for subsets

332

333

334

 (declaim (ftype (function (fixnum fixnum fixnum &optional (or null spocq:zone-fragment)) spocq:date) make-date)

335

          (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum &optional (or null spocq:zone-fragment)) spocq:date-time) make-date-time)

336

          (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum) spocq:duration) make-duration)

337

          (ftype (function (fixnum fixnum fixnum fixnum fixnum) spocq:day-time-duration) make-day-time-duration)

338

(ftype (function (fixnum &optional (or null spocq:zone-fragment)) spocq:g-day) make-g-day)

339

          (ftype (function (fixnum &optional (or null spocq:zone-fragment)) spocq:g-month) make-g-month)

340

(ftype (function (fixnum &optional (or null spocq:zone-fragment)) spocq:g-year) make-g-year)

341

          (ftype (function (fixnum fixnum &optional (or null spocq:zone-fragment)) spocq:g-month-day) make-g-month-day)

342

          (ftype (function (fixnum fixnum &optional (or null spocq:zone-fragment)) spocq:g-year-month) make-g-year-month)

343

          (ftype (function (fixnum fixnum fixnum fixnum &optional (or null spocq:zone-fragment)) spocq:time) make-time)

344

(ftype (function (fixnum fixnum) spocq:year-month-duration) make-year-month-duration))

345

346

 (declaim (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum &optional real) spocq:date) encode-date)

347

          (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum &optional real) spocq:date-time) encode-date-time)

348

          (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum &optional real) spocq:duration) encode-duration)

349

          (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum &optional real) spocq:day-time-duration) encode-day-time-duration)

350

          (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum &optional real) spocq:g-day) encode-g-day)

351

          (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum &optional real) spocq:g-month) encode-g-month)

352

          (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum &optional real) spocq:g-year) encode-g-year)

353

          (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum &optional real) spocq:g-month-day) encode-g-month-day)

354

          (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum &optional real) spocq:g-year-month) encode-g-year-month)

355

          (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum &optional real) spocq:time) encode-time)

356

          (ftype (function (fixnum fixnum fixnum fixnum fixnum fixnum fixnum &optional real) spocq:year-month-duration) encode-year-month-duration))

357

358

 (declaim (ftype (function (string) (values fixnum fixnum fixnum fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) parse-|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?|)

359

          (ftype (function (string) (values fixnum fixnum fixnum (or null spocq:zone-fragment))) parse-|-yyyy-MM-dd(ZZZZ)?|)

360

361

(ftype (function (string &optional boolean) t) parse-|PnDTnHnMnS|)

362

(ftype (function (string &optional boolean) t) parse-|PnYnM|)

363

364

          (ftype (function (string) (values fixnum (or null spocq:zone-fragment))) parse-|---dd(ZZZZZZ)?|)

365

          (ftype (function (string) (values fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) parse-|HH:mm:ss(ZZZZ)?|))

366

367

;;; define mediating temporal accessors

368

;;; for the classes date date-time day-time-duration and year-month-duration

369

;;; interpose logic which checks to see the initialization state and parses

370

;;; the lexical form on demand.

371

372

;;;

373

;;; date

374

375

(defun constrain-date-fragments (day month year zone)

376

(constrain-temporal-fragments (day month year zone) |xsd|:|date|))

377

378

(defun normalize-date-fragments (day month year)

379

(normalize-location-day-month-to-year day month year)

380

(values day month year))

381

382

(test:test spocq.temporal-data.normalize-date-fragments

383

(loop for i from -13 to 13 collect

384

(let ((day 365) (month i) (year 1900))

385

(list i (multiple-value-list (normalize-date-fragments day month year)))))

386

'((-13 (31 10 1899)) (-12 (30 11 1899)) (-11 (31 12 1899)) (-10 (31 1 1900))

387

(-9 (28 2 1900)) (-8 (31 3 1900)) (-7 (30 4 1900)) (-6 (31 5 1900))

388

(-5 (30 6 1900)) (-4 (31 7 1900)) (-3 (31 8 1900)) (-2 (30 9 1900))

389

(-1 (31 10 1900)) (0 (30 11 1900)) (1 (31 12 1900)) (2 (31 1 1901))

390

(3 (28 2 1901)) (4 (31 3 1901)) (5 (30 4 1901)) (6 (31 5 1901))

391

(7 (30 6 1901)) (8 (31 7 1901)) (9 (31 8 1901)) (10 (30 9 1901))

392

(11 (31 10 1901)) (12 (30 11 1901)) (13 (31 12 1901))))

393

394

;;; no canonicalization as it requires time fragments canonicalize-date-time-fragments must be used

395

396

(defun make-date (day month year &optional (zone spocq:+reference-zone+))

397

"Given minute hour day month year fragments, make a date.

398

First, normalize then canonicalize fragments as required."

399

   (encode-date spocq::+reference-fraction+ spocq:+reference-second+ spocq:+reference-minute+ spocq:+reference-hour+

400

day month year

401

zone))

402

403

(defun encode-date (fraction second minute hour day month year &optional (zone spocq:+reference-zone+))

404

   "Given all temporal fragments, construct a date with the specified zoned fragments normalized to utc.

405

  The fragment value are canonicalized to zulu time in order facilitate comparisons, but the zone is retained.

406

Supplied second, minute and hour if any, are ignored, as they do not apply, but

407

the minute and hour which results from canonicalization are recorded."

408

(multiple-value-setq (day month year)

409

(normalize-date-fragments day month year))

410

(when (offset-zone-p zone)

411

(multiple-value-setq (fraction second minute hour day month year)

412

(canonicalize-date-time-fragments fraction second minute hour day month year zone)))

413

(spocq:make-date :minute minute :hour hour :day day :month month :year year :zone zone))

414

415

416

(defun parse-|-yyyy-MM-dd(ZZZZ)?| (string)

417

"Given a date lexical form, return the encoded fragments, unmodified, as extracted."

418

(handler-case

419

(multiple-value-bind (match substrings)

420

                          (cl-ppcre:scan-to-strings (load-time-value (cl-ppcre:create-scanner "^(-)?([1-9][0-9][0-9][0-9]+)-([0-1][0-9])-([0-3][0-9])(([zZ])|([+-])([0-9][0-9]):([0-9][0-9]))?$"))

421

string)

422

(assert match () "invalid xsd:date lexical form")

423

(let* ((sign (if (equal (aref substrings 0) "-") -1 +1))

424

(year (* sign (parse-integer (aref substrings 1))))

425

(month (parse-integer (aref substrings 2)))

426

(day (parse-integer (aref substrings 3))))

427

(if (aref substrings 4)

428

(if (aref substrings 5)

429

(values day month year spocq:+reference-zone+)

430

(let* ((zone-sign (aref substrings 6))

431

(zone-hours (aref substrings 7))

432

(zone-minutes (aref substrings 8)))

433

(values day month year

434

(* (if (equal zone-sign "-") -1 1)

435

(+ (parse-integer zone-hours)

436

(/ (parse-integer zone-minutes) 60))))))

437

(values day month year nil))))

438

(error ()

439

(invalid-argument-type |xsd|:|date| string |xsd|:|date|))))

440

441

;;; (parse-|-yyyy-MM-dd(ZZZZ)?| "-0001-12-31") ;; should fail

442

;;; (parse-|-yyyy-MM-dd(ZZZZ)?| "1999-12-31Z")

443

;;; (parse-|-yyyy-MM-dd(ZZZZ)?| "-11111-12-31") ;; should succeed

444

;;; (parse-|-yyyy-MM-dd(ZZZZ)?| "-1999-12-31-00:00")

445

;;; (parse-|-yyyy-MM-dd(ZZZZ)?| "-1999-12-31+10:20")

446

;;; (parse-|-yyyy-MM-dd(ZZZZ)?| "2020-12-01-06:01")

447

;;; (parse-|-yyyy-MM-dd(ZZZZ)?| "2020-12-01+06:01")

448

449

(defmethod temporal-decoded-p ((term spocq:date))

450

(not (null (spocq:date-year term))))

451

452

(defgeneric decode-date (value)

453

   (:documentation "GIven a date instance or a timeline or string designator, return the respective fragments.

454

If the instance itself has not yet been initialized, do so from the avaialble designator")

455

456

(:method ((value spocq:date))

457

"If the fragments are current, return them, otherwise deconstruct or parse as available."

458

(let ((year (spocq:date-year value)))

459

(if year

460

(values 0 0 (spocq:date-minute value) (spocq:date-hour value)

461

(spocq:date-day value) (spocq:date-month value) year

462

(spocq:date-zone value))

463

(flet ((update-fragments (fraction second minute hour day month year zone)

464

;; nb.!!! the lexical form can end up out-of-sync with the fragments

465

(values fraction

466

second

467

(setf (spocq:date-minute value) minute)

468

(setf (spocq:date-hour value) hour)

469

(setf (spocq:date-day value) day)

470

(setf (spocq:date-month value) month)

471

(setf (spocq:date-year value) year)

472

(setf (spocq:date-zone value) zone))))

473

(let ((location (spocq:temporal-timeline-location value)))

474

(if location

475

(multiple-value-call #'update-fragments (decode-date location))

476

(let ((lexical-form (spocq:literal-lexical-form value)))

477

(if lexical-form

478

(multiple-value-call #'update-fragments (decode-date lexical-form))

479

(error "Invalid date: ~s" value)))))))))

480

481

(:method ((location integer))

482

"Given a location, parse it and return the fragments. Pin the zone."

483

(multiple-value-bind (fraction second minute hour day month year)

484

(dydra-ndk::decode-time location spocq:+reference-zone+)

485

(values fraction second minute hour day month year spocq:+reference-zone+)))

486

487

(:method ((lexical-form string))

488

"Given a lexical form string, parse it, constrain, then canonicalize, then return.

489

No normalization happens, as the lexical contraints proscribe such values."

490

(multiple-value-bind (day month year zone)

491

                          (multiple-value-call #'constrain-date-fragments (parse-|-yyyy-MM-dd(ZZZZ)?| lexical-form))

492

(unless zone (setf zone spocq:+reference-zone+))

493

(if (offset-zone-p zone)

494

(multiple-value-bind (fraction second minute hour day month year)

495

                              (canonicalize-date-time-fragments 0 0 0 0 day month year zone spocq:+reference-zone+)

496

(values fraction second minute hour day month year zone))

497

(values 0 0 0 0 day month year zone)))))

498

 (declaim (ftype (function ((or spocq:date string integer)) (values fixnum fixnum fixnum fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) decode-date))

499

500

 (defmethod spocq:format-date (stream (object spocq:date) &optional expand-zulu-p offset-zone-p (zone (date-zone object)))

501

;; always format for zone

502

(declare (ignore offset-zone-p))

503

(multiple-value-bind (fraction second minute hour day month year) (decode-date object)

504

(when (offset-zone-p zone)

505

(multiple-value-setq (fraction second minute hour day month year)

506

         (canonicalize-date-time-fragments fraction second minute hour day month year spocq:+reference-zone+ zone)))

507

#| ;; should already be canonicalized

508

(cond ((or (> hour 12) (and (= hour 12) (or (> minute 0) (> second 0))))

509

(incf day) (decf hour 23) (decf minute 60) (decf second 60)

510

(normalize-location-day-month-to-year day month year))

511

((<= hour -12)

512

(decf day) (incf hour 23) (decf minute 60) (decf second 60)

513

(normalize-location-day-month-to-year day month year)))

514

(format stream "~:[~;-~]~4,'0d-~2,'0d-~2,'0d" (minusp year) (abs year) month day)

515

;;; the zone has been canonicalized to hours nor minutes

516

(cond ((and (zerop minute) (zerop hour))

517

(when expand-zulu-p

518

(write-char #\Z stream)))

519

(t

520

(format stream "~:[-~;+~]~2,'0d:~2,'0d" (minusp hour) (abs hour) (abs minute))))

521

;; no zone is left

522

)) |#

523

(format stream "~:[~;-~]~4,'0d-~2,'0d-~2,'0d" (minusp year) (abs year) month day)

524

;;; the zone has been canonicalized to hours nor minutes

525

(let ((date-zone (date-zone object)))

526

(if (offset-zone-p date-zone)

527

(multiple-value-bind (hour minute) (floor (* (abs date-zone) 60) 60)

528

(format stream "~:[-~;+~]~2,'0d:~2,'0d" (plusp date-zone) hour minute))

529

(when expand-zulu-p

530

(write-char #\Z stream))))))

531

532

533

(defgeneric |-yyyy-MM-dd(ZZZZ)?| (object)

534

(:method ((object string))

535

(multiple-value-bind (fraction second minute hour day month year zone)

536

(decode-date object)

537

(declare (ignore fraction second))

538

(spocq:make-date :minute minute :hour hour :day day :month month :year year

539

:zone zone :lexical-form object)))

540

(:method ((object spocq:date))

541

;; double check for an extant lexical form

542

(or (spocq:literal-lexical-form object)

543

(setf (spocq:literal-lexical-form object)

544

;; generate a new lexical form, offset as per zone

545

(with-output-to-string (stream) (spocq:format-date stream object))))))

546

;;; (|-yyyy-MM-dd(ZZZZ)?| "1999-01-01")

547

;;; (|-yyyy-MM-dd(ZZZZ)?| "1999-01-01")

548

;;; (|-yyyy-MM-dd(ZZZZ)?| "2020-12-01-06:01")

549

;;; (|-yyyy-MM-dd(ZZZZ)?| "2020-12-01+06:01")

550

551

(defun universal-time-date (time)

552

(multiple-value-bind (sec min hour day month year)

553

(decode-universal-time time 0)

554

(declare (ignore sec))

555

(spocq:make-date :minute min :hour hour :day day :month month :year year)))

556

557

(defun date-universal-time (date)

558

(timeline-location-universal-time (date-timeline-location date)))

559

;; (truncate (date-timeline-location date) +timeline-units-per-second+))

560

561

(defun timeline-location-date (value)

562

(spocq:make-date :timeline-location value :zone spocq:+reference-zone+))

563

;;; (timeline-location-date (date-timeline-location (|-yyyy-MM-dd(ZZZZ)?| "2020-12-01-06:01")))

564

;;; (timeline-location-date (date-timeline-location (|-yyyy-MM-dd(ZZZZ)?| "2020-12-01+06:01")))

565

;;; (timeline-location-date (date-timeline-location (|-yyyy-MM-dd(ZZZZ)?| "2002-10-10+13:00")))

566

;;; (timeline-location-date (date-timeline-location (|-yyyy-MM-dd(ZZZZ)?| "2002-10-09-11:00")))

567

568

(defun date-timeline-location (date)

569

"Given a date, return the cached temporal value or compute it from the components."

570

(or (spocq:temporal-timeline-location date)

571

(setf (spocq:temporal-timeline-location date)

572

(multiple-value-bind (fraction second minute hour day month year)

573

(decode-date date)

574

;; drop the zone

575

               (dydra-ndk::encode-time fraction second minute hour day month year spocq:+reference-zone+)))))

576

577

#+(or)

578

(progn

579

;; verify formatting and round-tripping through the store.

580

(equal (loop for hour from -12 to 12 by 1

581

for abs-hour = (abs hour)

582

append (loop for minute from 0 to 59

583

for format = (format nil "2020-12-01~:[-~;+~]~2,'0d:~2,'0d"

584

(plusp hour)

585

abs-hour minute)

586

for date = (spocq.e:date format)

587

                     unless (equal (with-output-to-string (stream) (spocq:format-date stream date))

588

format)

589

                     collect (list format (with-output-to-string (stream) (spocq:format-date stream date)))))

590

'(("2020-12-01-00:00" "2020-12-01")))

591

(loop for hour from -12 to 12 by 1

592

for abs-hour = (abs hour)

593

append (loop for minute from 0 to 59

594

for format = (format nil "2020-12-01~:[-~;+~]~2,'0d:~2,'0d"

595

(plusp hour)

596

abs-hour minute)

597

for query = (format nil "construct {

598

[ <http://example.org#value> ?o ]

599

}

600

where {

601

values ?o {

602

'~a'^^xsd:date

603

}

604

}" format)

605

for ((nil nil query-date)) = (test-sparql query :repository-id "test/test")

606

              for query-format = (with-output-to-string (stream) (spocq:format-date stream query-date))

607

unless (equal query-format format)

608

collect (list format query-format)))

609

'(("2020-12-01-00:00" "2020-12-01")))

610

;;;

611

;;; date-time

612

613

(defun constrain-date-time-fragments (fraction second minute hour day month year zone)

614

(constrain-temporal-fragments (fraction second minute hour day month year zone) |xsd|:|dateTime|))

615

616

(defun normalize-date-time-fragments (fraction second minute hour day month year)

617

(normalize-location-fraction-second-to-minute fraction second minute)

618

(normalize-location-minute-to-hour minute hour)

619

(normalize-location-hour-to-day hour day)

620

(normalize-location-day-month-to-year day month year)

621

(values fraction second minute hour day month year))

622

623

(test:test spocq.temporal-data.normalize-date-time-fragments

624

   (list (loop for month from 1 to 12 collect (list month (multiple-value-list (normalize-date-time-fragments 0 65 59 23 31 month 1900))))

625

         (loop for month from -1 downto -12 by 1 collect (list month (multiple-value-list (normalize-date-time-fragments 0 65 59 23 31 month 1900)))))

626

'(((1 (0 5 0 0 1 2 1900)) (2 (0 5 0 0 4 3 1900)) (3 (0 5 0 0 1 4 1900))

627

(4 (0 5 0 0 2 5 1900)) (5 (0 5 0 0 1 6 1900)) (6 (0 5 0 0 2 7 1900))

628

(7 (0 5 0 0 1 8 1900)) (8 (0 5 0 0 1 9 1900)) (9 (0 5 0 0 2 10 1900))

629

(10 (0 5 0 0 1 11 1900)) (11 (0 5 0 0 2 12 1900)) (12 (0 5 0 0 1 1 1901)))

630

((-1 (0 5 0 0 2 12 1899)) (-2 (0 5 0 0 1 11 1899)) (-3 (0 5 0 0 2 10 1899))

631

(-4 (0 5 0 0 1 9 1899)) (-5 (0 5 0 0 1 8 1899)) (-6 (0 5 0 0 2 7 1899))

632

(-7 (0 5 0 0 1 6 1899)) (-8 (0 5 0 0 2 5 1899)) (-9 (0 5 0 0 1 4 1899))

633

(-10 (0 5 0 0 4 3 1899)) (-11 (0 5 0 0 1 2 1899)) (-12 (0 5 0 0 1 1 1899)))))

634

635

 (defun canonicalize-date-time-fragments (fraction second minute hour day month year zone &optional (to-zone spocq:+reference-zone+))

636

   "Canonicalize full fragment complement by shifting to a date which is legal for universal time, canonicalizing

637

and then shifting back"

638

(if (or (offset-zone-p zone) (offset-zone-p to-zone))

639

(multiple-value-bind (cycles cycle-year) (truncate year 400)

640

(declare (ignore cycles))

641

(let ((proxy-year (+ cycle-year 2300)))

642

(multiple-value-bind (s-sec s-min s-hour s-day s-month s-year)

643

                              (decode-universal-time (encode-universal-time second minute hour day month proxy-year (- zone)) (- to-zone))

644

;; retain the possible non-zero offset hour and minute

645

           (values fraction s-sec s-min s-hour s-day s-month (+ year (- s-year proxy-year)) zone))))

646

(values fraction second minute hour day month year zone)))

647

648

(defun make-date-time (fraction second minute hour day month year &optional (zone spocq:+reference-zone+))

649

(encode-date-time fraction second minute hour day month year zone))

650

651

 (defun encode-date-time (fraction second minute hour day month year &optional (zone spocq:+reference-zone+))

652

   "Given all temporal fragments, construct a date-time with the specified zoned fragments normalized to utc.

653

  The fragment value are canonicalized to zulu time in order facilitate comparisons, but the zone is retained.

654

Handle the year so as to allow negative values."

655

(multiple-value-setq (fraction second minute hour day month year)

656

                        (normalize-date-time-fragments fraction second minute hour day month year))

657

(when (offset-zone-p zone)

658

(multiple-value-setq (fraction second minute hour day month year)

659

       (canonicalize-date-time-fragments fraction second minute hour day month year zone spocq:+reference-zone+)))

660

(spocq:make-date-time :fraction fraction :second second :minute minute :hour hour

661

:day day :month month :year year

662

:zone zone))

663

664

;; support just iso8601 with 'T|t' and canonicalize destructively to 'T'

665

(setf (cl-ppcre:parse-tree-synonym 'date-time)

666

       (cl-ppcre:parse-string "(-)?([1-9][0-9][0-9][0-9]+)-([0-1][0-9])-([0-3][0-9])[tT]([0-9][0-9]):([0-9][0-9]):([0-9][0-9])(?:\\.([0-9]+))?(([zZ])|([+-])([0-9][0-9]):([0-9][0-9]))?"))

667

(setf (cl-ppcre:parse-tree-synonym 'date-time-string)

668

       (cl-ppcre:parse-string "-?[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9][tT][0-9][0-9]:[0-9][0-9]:[0-9][0-9](?:\\.[0-9]+)?(?:[zZ]|[+-]-9][0-9]:[0-9][0-9])?"))

669

670

(defun parse-|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| (string)

671

"Given a date-time lexical form, return the encoded fragments, unmodified, as extracted."

672

(handler-case

673

(multiple-value-bind (match substrings)

674

                          (cl-ppcre:scan-to-strings (load-time-value (cl-ppcre:create-scanner '(:sequence :start-anchor date-time :end-anchor)))

675

string)

676

(assert match () "invalid date-time lexical form")

677

(let* ((sign-char (aref substrings 0))

678

(sign (if (equal sign-char "-") -1 +1))

679

(year (* sign (parse-integer (aref substrings 1))))

680

(month (parse-integer (aref substrings 2)))

681

(day (parse-integer (aref substrings 3)))

682

(hour (parse-integer (aref substrings 4)))

683

(minute (parse-integer (aref substrings 5)))

684

(second (parse-integer (aref substrings 6)))

685

(fraction (let* ((string (aref substrings 7))

686

(integer (if string (parse-integer string) 0)))

687

(if (zerop integer) 0

688

(/ (* +timeline-units-per-second+ integer)

689

                                 (aref #(1 10 100 1000 10000 100000 1000000) (min (length string) 6)))))))

690

(when (eql (char string (if sign-char 11 10)) #\t)

691

(setf (char string (if sign-char 11 10)) #\T))

692

(if (aref substrings 8)

693

(if (aref substrings 9)

694

(values fraction second minute hour day month year spocq:+reference-zone+)

695

(let* ((zone-sign (aref substrings 10))

696

(zone-hours (aref substrings 11))

697

(zone-minutes (aref substrings 12)))

698

(values fraction second minute hour day month year

699

(* (if (equal zone-sign "-") -1 1)

700

(+ (parse-integer zone-hours)

701

(/ (parse-integer zone-minutes) 60))))))

702

(values fraction second minute hour day month year nil))))

703

(error ()

704

(invalid-argument-type |xsd|:|dateTime| string |xsd|:|dateTime|))))

705

706

(defmethod temporal-decoded-p ((term spocq:date-time))

707

(not (null (spocq:date-time-year term))))

708

709

(defmethod ensure-temporal-decoded ((term spocq:date-time))

710

(unless (temporal-decoded-p term)

711

(decode-date-time term))

712

term)

713

714

(defgeneric decode-date-time (value)

715

   (:documentation "GIven a date-time instance or a timeline or string designator, return the respective fragments.

716

If the instance itself has not yet been initialized, do so from the avaialble designator")

717

718

(:method ((value spocq:date-time))

719

"If the fragments are current, return them, otherwise deconstruct or parse as available."

720

(let ((year (spocq:date-time-year value)))

721

(if year

722

         (values (spocq:date-time-fraction value) (spocq:date-time-second value) (spocq:date-time-minute value)

723

                 (spocq:date-time-hour value) (spocq:date-time-day value) (spocq:date-time-month value) year

724

(spocq:date-time-zone value))

725

(flet ((update-fragments (fraction second minute hour day month year zone)

726

(values (setf (spocq:date-time-fraction value) fraction)

727

(setf (spocq:date-time-second value) second)

728

(setf (spocq:date-time-minute value) minute)

729

(setf (spocq:date-time-hour value) hour)

730

(setf (spocq:date-time-day value) day)

731

(setf (spocq:date-time-month value) month)

732

(setf (spocq:date-time-year value) year)

733

(setf (spocq:date-time-zone value) zone))))

734

(let ((location (spocq:temporal-timeline-location value)))

735

(if location

736

(multiple-value-call #'update-fragments (decode-date-time location))

737

(let ((lexical-form (spocq:literal-lexical-form value)))

738

(if lexical-form

739

(multiple-value-call #'update-fragments (decode-date-time lexical-form))

740

(error "Invalid date-time: ~s" value)))))))))

741

742

(:method ((location integer))

743

"Given a location, parse it and return the fragments. Pin the zone."

744

(multiple-value-bind (fraction second minute hour day month year)

745

(dydra-ndk::decode-time location spocq:+reference-zone+)

746

(values fraction second minute hour day month year spocq:+reference-zone+)))

747

748

(:method ((lexical-form string))

749

"Given a lexical form string, parse it, nomalize, then canonicalize, then return.

750

nb.!!! the lexical form can end up out-of-sync with the fragments"

751

(multiple-value-bind (fraction second minute hour day month year zone)

752

                          (multiple-value-call #'constrain-date-time-fragments (parse-|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| lexical-form))

753

(when (= 24 hour)

754

(incf day)

755

(setf hour 0))

756

(unless zone (setf zone spocq:+reference-zone+))

757

(multiple-value-setq (fraction second minute hour day month year)

758

(normalize-date-time-fragments fraction second minute hour day month year))

759

(when (offset-zone-p zone)

760

(multiple-value-setq (fraction second minute hour day month year)

761

           (canonicalize-date-time-fragments fraction second minute hour day month year zone spocq:+reference-zone+)))

762

(values fraction second minute hour day month year zone))))

763

 (declaim (ftype (function ((or spocq:date-time string integer)) (values fixnum fixnum fixnum fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) decode-date-time))

764

;;; (decode-date-time "1999-01-01T24:02:03.5Z")

765

;;; (decode-date-time "2020-12-01T00:00:00Z+06:00") -> invalid

766

;;; (decode-date-time "2020-12-01T00:00:00+06:00") -> valid

767

768

769

 (defmethod spocq:format-date-time (stream (object spocq:date-time) &optional expand-zulu-p offset-zone-p (zone spocq:+reference-zone+))

770

;; always format

771

(multiple-value-bind (fraction second minute hour day month year) (decode-date-time object)

772

(when (and offset-zone-p (offset-zone-p zone))

773

(multiple-value-setq (fraction second minute hour day month year)

774

         (canonicalize-date-time-fragments fraction second minute hour day month year spocq:+reference-zone+ zone)))

775

(format stream "~:[~;-~]~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d~@[~a~]"

776

(minusp year) (abs year) month day hour minute second

777

(unless (zerop fraction)

778

(let* ((float (float (/ (abs fraction) +timeline-units-per-second+)))

779

(string (format nil "~f" float)))

780

(subseq string 1))))

781

(spocq:format-zone-offset stream zone expand-zulu-p nil)))

782

(defmethod spocq:format-date-time (stream (object integer) &optional expand-zulu-p offset-zone-p (zone 0))

783

"Given an integer, treat the value as a unix timestamp"

784

(spocq:format-date-time stream (timeline-location-date-time object) expand-zulu-p offset-zone-p zone))

785

786

(defgeneric |-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| (object)

787

(:method ((object string))

788

(multiple-value-bind (fraction second minute hour day month year zone)

789

(decode-date-time object)

790

(spocq:make-date-time :fraction fraction :second second :minute minute :hour hour

791

:day day :month month :year year

792

:zone zone :lexical-form object)))

793

(:method ((object spocq:date-time))

794

;; double check for an extant lexical form

795

(or (spocq:literal-lexical-form object)

796

(setf (spocq:literal-lexical-form object)

797

;; do not format the zone unless it is non-zero

798

(with-output-to-string (stream) (spocq:format-date-time stream object nil t))))))

799

;;; (|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| "1999-01-01T24:02:03.5Z")

800

;;; (|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| "2020-12-01T00:00:00Z+06:00") ?

801

802

803

(defun universal-time-date-time (time)

804

(multiple-value-bind (sec min hour day month year)

805

(decode-universal-time time 0)

806

     (spocq:make-date-time :fraction 0 :second sec :minute min :hour hour :day day :month month :year year

807

:zone 0)))

808

809

(defun date-time-universal-time (date-time)

810

(timeline-location-universal-time (date-time-timeline-location date-time)))

811

;; (truncate (date-time-timeline-location date-time) +timeline-units-per-second+))

812

813

(defun timeline-location-date-time (value)

814

(spocq:make-date-time :timeline-location value :zone spocq:+reference-zone+))

815

816

(defun date-time-timeline-location (date-time)

817

"Given a date-time, return the cached temporal value or compute it from the components."

818

(or (spocq:temporal-timeline-location date-time)

819

(setf (spocq:temporal-timeline-location date-time)

820

(multiple-value-bind (fraction second minute hour day month year)

821

(decode-date-time date-time)

822

;; drop the zone

823

               (dydra-ndk::encode-time fraction second minute hour day month year spocq:+reference-zone+)))))

824

825

826

827

;;;

828

;;; day-time-duration

829

830

(defun constrain-day-time-duration-fragments (fraction second minute hour day)

831

(constrain-temporal-fragments (fraction second minute hour day) |xsd|:|dayTimeDuration|))

832

833

(defun normalize-day-time-duration-fragments (fraction second minute hour day)

834

(normalize-duration-fraction-second-to-minute fraction second minute)

835

(normalize-duration-minute-to-hour minute hour)

836

(normalize-duration-hour-to-day hour day)

837

(values fraction second minute hour day))

838

839

(test:test spocq.temporal-data.normalize-day-time-duration-fragments

840

   (list (loop for hour from 0 to 48 by 4 collect (list hour (multiple-value-list (normalize-day-time-duration-fragments 1 60 59 hour 31))))

841

         (loop for hour from 0 downto -48 by 4 collect (list hour (multiple-value-list (normalize-day-time-duration-fragments 1 -60 0 hour 1)))))

842

'(((0 (1 0 0 1 31)) (4 (1 0 0 5 31)) (8 (1 0 0 9 31)) (12 (1 0 0 13 31))

843

(16 (1 0 0 17 31)) (20 (1 0 0 21 31)) (24 (1 0 0 1 32)) (28 (1 0 0 5 32))

844

(32 (1 0 0 9 32)) (36 (1 0 0 13 32)) (40 (1 0 0 17 32)) (44 (1 0 0 21 32))

845

(48 (1 0 0 1 33)))

846

((0 (1 0 -1 0 1)) (-4 (1 0 -1 -4 1)) (-8 (1 0 -1 -8 1)) (-12 (1 0 -1 -12 1))

847

(-16 (1 0 -1 -16 1)) (-20 (1 0 -1 -20 1)) (-24 (1 0 -1 0 0))

848

(-28 (1 0 -1 -4 0)) (-32 (1 0 -1 -8 0)) (-36 (1 0 -1 -12 0))

849

(-40 (1 0 -1 -16 0)) (-44 (1 0 -1 -20 0)) (-48 (1 0 -1 0 -1)))) )

850

851

;;; no canonicalization, as no zone is present

852

853

(defun make-day-time-duration (fraction second minute hour day)

854

"Given fraction, second, minute, hour and day fragments, make a day-time-duration."

855

(encode-day-time-duration fraction second minute hour day spocq:+reference-month+ spocq:+reference-year+))

856

857

(defun encode-day-time-duration (fraction second minute hour day month year &optional (zone 0))

858

"Given temporal fragments, construct a day-time-duration.

859

month and year are, if any, are ignored, as they do not apply.

860

Constrain fragments according to the respective lexical constraints."

861

(declare (ignore month year zone))

862

(multiple-value-setq (fraction second minute hour day)

863

(normalize-day-time-duration-fragments fraction second minute hour day))

864

(spocq:make-day-time-duration :fraction fraction :second second :minute minute :hour hour :day day))

865

866

867

(setf (cl-ppcre:parse-tree-synonym 'day-time-duration)

868

       (cl-ppcre:parse-string "(-)?P(?:([0-9]+)D)?(?:T(?:([0-9]+)H)?(?:([0-9]+)M)?(?:([0-9]+)(?:\\.([0-9]+))?S)?)?"))

869

(setf (cl-ppcre:parse-tree-synonym 'day-time-duration-string)

870

(cl-ppcre:parse-string "-?P(?:[0-9]+D)?(?:T(?:[0-9]+H)?(?:[0-9]+M)?(?:[0-9]+(?:\\.[0-9]+)?S)?)?"))

871

872

(defun parse-|PnDTnHnMnS| (string &optional (error-p t))

873

(handler-case

874

(multiple-value-bind (match substrings)

875

                          (cl-ppcre:scan-to-strings (load-time-value (cl-ppcre:create-scanner '(:sequence :start-anchor day-time-duration :end-anchor)))

876

string)

877

(cond (match

878

(let ((sign (if (equal (aref substrings 0) "-") -1 +1)))

879

(flet ((field-integer (string) (if string (* sign (parse-integer string)) 0)))

880

(values (round (let ((integer (field-integer (aref substrings 5))))

881

(if (zerop integer) 0

882

                                       (/ (* +timeline-units-per-second+ integer)

883

                                          (aref #(1 10 100 1000 10000 100000 1000000) (min (length (aref substrings 5)) 6))))))

884

(field-integer (aref substrings 4))

885

(field-integer (aref substrings 3))

886

(field-integer (aref substrings 2))

887

(field-integer (aref substrings 1))))))

888

(error-p

889

(assert match () "invalid xsd:dayTimeDuration lexical form"))))

890

(error ()

891

(invalid-argument-type |xsd|:|dayTimeDuration| string |xsd|:|dayTimeDuration|))))

892

893

;;; (parse-|PnDTnHnMnS| "P1DT2H3M4S")

894

 ;;; (cl-ppcre:scan-to-strings (cl-ppcre:create-scanner '(:sequence :start-anchor day-time-duration-string :end-anchor)) "P1DT2H3M4S")

895

896

(defmethod temporal-decoded-p ((term spocq:day-time-duration))

897

(not (null (spocq:day-time-duration-day term))))

898

899

(defmethod ensure-temporal-decoded ((term spocq:day-time-duration))

900

(unless (temporal-decoded-p term)

901

(decode-day-time-duration term))

902

term)

903

904

(defgeneric decode-day-time-duration (value)

905

   (:documentation "GIven a day-time-duration return all temporal fragments, whereby only the those beween the day and the fragment signify

906

and the remainder are clamped to zero.")

907

908

(:method ((value spocq:day-time-duration))

909

(let ((day (spocq:day-time-duration-day value)))

910

(if day

911

(values (spocq:day-time-duration-fraction value)

912

(spocq:day-time-duration-second value)

913

(spocq:day-time-duration-minute value)

914

(spocq:day-time-duration-hour value)

915

day

916

(spocq:day-time-duration-month value)

917

(spocq:day-time-duration-year value)

918

spocq:+reference-zone+)

919

(flet ((update-fragments (fraction second minute hour day month year zone)

920

;; nb.!!! the lexical form can end up out-of-sync with the fragments

921

(values (setf (spocq:day-time-duration-fraction value) fraction)

922

(setf (spocq:day-time-duration-second value) second)

923

(setf (spocq:day-time-duration-minute value) minute)

924

(setf (spocq:day-time-duration-hour value) hour)

925

(setf (spocq:day-time-duration-day value) day)

926

(setf (spocq:day-time-duration-month value) month)

927

(setf (spocq:day-time-duration-year value) year)

928

zone)))

929

(let ((time-location (spocq:day-time-duration-second-location value)))

930

(if time-location

931

(multiple-value-call #'update-fragments (decode-day-time-duration time-location))

932

(let ((lexical-form (spocq:literal-lexical-form value)))

933

(if lexical-form

934

                   (multiple-value-call #'update-fragments (decode-day-time-duration lexical-form))

935

(error "Invalid day-time-duration: ~s" value)))))))))

936

937

(:method ((time-location integer))

938

(multiple-value-bind (surplus fraction) (truncate time-location +timeline-units-per-second+)

939

(multiple-value-bind (surplus second) (truncate surplus +timeline-seconds-per-minute+)

940

(multiple-value-bind (surplus minute) (truncate surplus +timeline-minutes-per-hour+)

941

(multiple-value-bind (day hour) (truncate surplus +timeline-hours-per-day+)

942

(values fraction second minute hour day 0 0 0))))))

943

944

(:method ((lexical-form string))

945

"Given a lexical form string, parse it, constrain, then canonicalize, then return.

946

Normalize the values."

947

(multiple-value-bind (fraction second minute hour day)

948

                          (multiple-value-call #'normalize-day-time-duration-fragments (parse-|PnDTnHnMnS| lexical-form))

949

(values fraction second minute hour day 0 0 0))))

950

 (declaim (ftype (function ((or spocq:day-time-duration string integer)) (values fixnum fixnum fixnum fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) decode-day-time-duration))

951

952

(defmethod spocq:format-day-time-duration (stream (object spocq:day-time-duration) &optional colon at)

953

(declare (ignore colon at))

954

(let* ((day (day-time-duration-day object)) ; the first access so, to ensure decoding

955

(hour (spocq:day-time-duration-hour object))

956

(minute (spocq:day-time-duration-minute object))

957

(second (spocq:day-time-duration-second object))

958

(fraction (spocq:day-time-duration-fraction object))

959

          (zero-duration (and (zerop day) (zerop minute) (zerop hour) (zerop second) (zerop fraction))))

960

(cond (zero-duration

961

(write-string "PT0S" stream))

962

(t

963

(format stream "~:[~;-~]P~@[~dD~]~:[T~@[~dH~]~@[~dM~]~:[~@[~d~]~@[~a~]S~;~]~;~]"

964

                      (or (minusp day) (minusp hour) (minusp minute) (minusp second) (minusp fraction))

965

(unless (zerop day) (abs day))

966

(and (zerop hour) (zerop minute) (zerop second) (zerop fraction))

967

(unless (zerop hour) (abs hour))

968

(unless (zerop minute) (abs minute))

969

(and (zerop second) (zerop fraction))

970

(unless (and (zerop second) (zerop fraction)) (abs second))

971

(unless (zerop fraction)

972

                        (let* ((float (float (/ (abs fraction) +timeline-units-per-second+)))

973

                               (string (format nil "~f" float))) ;;; ensure no scientific notation

974

(subseq string 1))))))))

975

976

(defgeneric |PnDTnHnMnS| (object)

977

(:method ((object string))

978

(let ((result (multiple-value-call #'make-day-time-duration (parse-|PnDTnHnMnS| object))))

979

(setf (spocq:literal-lexical-form result) object)

980

result))

981

982

(:method ((object spocq:day-time-duration))

983

(or (spocq:literal-lexical-form object)

984

(setf (spocq:literal-lexical-form object)

985

;; generate a new lexical form, offset as per zone

986

(with-output-to-string (stream) (spocq:format-day-time-duration stream object))))))

987

988

 ;;; (cl-ppcre:scan-to-strings "^(-)?P(?:([0-9]+)D)?T(?:([0-9]+)H)?(?:([0-9]+)M)?(?:([0-9]+)(?:\\.([0-9]+))?S)?$" "P10DT9H8M7.6S")

989

;;; (|PnDTnHnMnS| (|PnDTnHnMnS| "PT0S"))

990

;;; (|PnDTnHnMnS| (|PnDTnHnMnS| "PT120S"))

991

;;; (|PnDTnHnMnS| (|PnDTnHnMnS| "PT120M"))

992

;;; (|PnDTnHnMnS| (|PnDTnHnMnS| "PT120H"))

993

;;; (|PnDTnHnMnS| (|PnDTnHnMnS| "P12D"))

994

;;; (|PnDTnHnMnS| (|PnDTnHnMnS| "-PT1440M120S"))

995

;;; (|PnDTnHnMnS| (|PnDTnHnMnS| "P10DT9H8M7S"))

996

;;; (|PnDTnHnMnS| (|PnDTnHnMnS| "PT0.5S"))

997

998

(defun universal-time-day-time-duration (value)

999

   (multiple-value-bind (second minute hour day month year) (decode-universal-time value spocq:+reference-zone+)

1000

(declare (ignore month year))

1001

(spocq:make-day-time-duration :fraction 0 :second second :minute minute :hour hour :day day)))

1002

1003

(defun timeline-location-day-time-duration (value)

1004

   (multiple-value-bind (fraction second minute hour day month year) (dydra-ndk:decode-time value spocq:+reference-zone+)

1005

(declare (ignore month year))

1006

;; decrement the day as zero is 1.january

1007

     (spocq:make-day-time-duration :fraction fraction :second second :minute minute :hour hour :day (1- day))))

1008

1009

1010

(defmethod duration-month-location ((temporal spocq:day-time-duration))

1011

0)

1012

1013

(defmethod duration-second-location ((temporal spocq:day-time-duration))

1014

(day-time-duration-second-location temporal))

1015

1016

(defun day-time-duration-second-location (value)

1017

"Given a year-month-duration, return the cached location value or compute it from the components."

1018

(or (spocq:day-time-duration-second-location value)

1019

(setf (spocq:day-time-duration-second-location value)

1020

             (nth-value 1 (compute-duration-locations (spocq:day-time-duration-fraction (ensure-temporal-decoded value))

1021

                                                      (spocq:day-time-duration-second value)

1022

                                                      (spocq:day-time-duration-minute value)

1023

                                                      (spocq:day-time-duration-hour value)

1024

                                                      (spocq:day-time-duration-day value)

1025

0 0)))))

1026

1027

1028

1029

;;;

1030

;;; duration

1031

1032

(defun make-duration (fraction second minute hour day month year)

1033

"Given fraction, second, minute, hour and day fragments, make a duration."

1034

(encode-duration fraction second minute hour day month year))

1035

1036

(defun constrain-duration-fragments (fraction second minute hour day month year)

1037

(constrain-temporal-fragments (fraction second minute hour day month year) |xsd|:|duration|))

1038

1039

(defun normalize-duration-fragments (fraction second minute hour day month year)

1040

(normalize-duration-fraction-second-to-minute fraction second minute)

1041

(normalize-duration-minute-to-hour minute hour)

1042

(normalize-duration-hour-to-day hour day)

1043

;; the normalization does not carry from the day to the month

1044

(normalize-duration-month-to-year month year)

1045

(values fraction second minute hour day month year))

1046

1047

;;; no canonicalization, as no zone is present

1048

1049

1050

(defun encode-duration (fraction second minute hour day month year &optional (zone 0))

1051

"Given temporal fragments, construct a duration.

1052

month and year are, if any, are ignored, as they do not apply.

1053

Constrain fragments according to the respective lexical constraints."

1054

(declare (ignore zone))

1055

(multiple-value-setq (fraction second minute hour day month year)

1056

(normalize-duration-fragments fraction second minute hour day month year))

1057

   (spocq:make-duration :fraction fraction :second second :minute minute :hour hour :day day :month month :year year))

1058

1059

(setf (cl-ppcre:parse-tree-synonym 'duration)

1060

       (cl-ppcre:parse-string "(-)?P(?:([0-9]+)Y)?(?:([0-9]+)M)?(?:([0-9]+)D)?(?:T(?:([0-9]+)H)?(?:([0-9]+)M)?(?:([0-9]+)(?:\\.([0-9]+))?S)?)?"))

1061

1062

(defun parse-|PnYnMnDTnHnMnS| (string)

1063

(handler-case

1064

(multiple-value-bind (match substrings)

1065

                          (cl-ppcre:scan-to-strings (load-time-value (cl-ppcre:create-scanner "^(-)?P(?:([0-9]+)Y)?(?:([0-9]+)M)?(?:([0-9]+)D)?(?:T(?:([0-9]+)H)?(?:([0-9]+)M)?(?:([0-9]+)(?:\\.([0-9]+))?S)?)?$"))

1066

string)

1067

(assert match () "invalid xsd:duration lexical form")

1068

(let ((sign (if (equal (aref substrings 0) "-") -1 +1)))

1069

(flet ((field-integer (string) (if string (* sign (parse-integer string)) 0)))

1070

(values (round (let ((integer (field-integer (aref substrings 7))))

1071

(if (zerop integer) 0

1072

(/ (* +timeline-units-per-second+ integer)

1073

                                   (aref #(1 10 100 1000 10000 100000 1000000) (min (length (aref substrings 7)) 6))))))

1074

(field-integer (aref substrings 6))

1075

(field-integer (aref substrings 5))

1076

(field-integer (aref substrings 4))

1077

(field-integer (aref substrings 3))

1078

(field-integer (aref substrings 2))

1079

(field-integer (aref substrings 1))))))

1080

(error ()

1081

(invalid-argument-type |xsd|:|duration| string |xsd|:|duration|))))

1082

1083

;;; (parse-|PnYnMnDTnHnMnS| "P20Y10M1DT2H3M4S")

1084

1085

(defmethod temporal-decoded-p ((term spocq:duration))

1086

(not (null (spocq:duration-year term))))

1087

1088

(defmethod ensure-temporal-decoded ((term spocq:duration))

1089

(unless (temporal-decoded-p term)

1090

(decode-duration term))

1091

term)

1092

1093

(defgeneric decode-duration (value)

1094

(:documentation "GIven a duration return all temporal fragments.")

1095

1096

(:method ((value spocq:duration))

1097

(let ((year (spocq:duration-day value)))

1098

(if year

1099

(values (spocq:duration-fraction value)

1100

(spocq:duration-second value)

1101

(spocq:duration-minute value)

1102

(spocq:duration-hour value)

1103

(spocq:duration-day value)

1104

(spocq:duration-month value)

1105

year

1106

spocq:+reference-zone+)

1107

(flet ((update-fragments (fraction second minute hour day month year zone)

1108

;; nb.!!! the lexical form can end up out-of-sync with the fragments

1109

(print (list fraction second minute hour day month year zone))

1110

(values (setf (spocq:duration-fraction value) fraction)

1111

(setf (spocq:duration-second value) second)

1112

(setf (spocq:duration-minute value) minute)

1113

(setf (spocq:duration-hour value) hour)

1114

(setf (spocq:duration-day value) day)

1115

(setf (spocq:duration-month value) month)

1116

(setf (spocq:duration-year value) year)

1117

zone)))

1118

(let ((location (spocq:temporal-timeline-location value)))

1119

(if location

1120

(multiple-value-call #'update-fragments (decode-duration location))

1121

(let ((lexical-form (spocq:literal-lexical-form value)))

1122

(if lexical-form

1123

(multiple-value-call #'update-fragments (decode-duration lexical-form))

1124

(error "Invalid duration: ~s" value)))))))))

1125

1126

(:method ((location integer))

1127

"decode a time location for a duration in the same manner as for a data-time"

1128

(multiple-value-bind (fraction second minute hour day month year)

1129

(dydra-ndk::decode-time location spocq:+reference-zone+)

1130

(values fraction second minute hour day month year 0)))

1131

1132

(:method ((lexical-form string))

1133

"Given a lexical form string, parse it, constrain, then canonicalize, then return.

1134

Normalize the values."

1135

(multiple-value-bind (fraction second minute hour day month year)

1136

                          (multiple-value-call #'normalize-duration-fragments (parse-|PnYnMnDTnHnMnS| lexical-form))

1137

(values fraction second minute hour day month year 0))))

1138

 (declaim  (ftype (function ((or spocq:duration string integer)) (values fixnum fixnum fixnum fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) decode-duration))

1139

1140

1141

(defmethod spocq:format-duration (stream (object spocq:duration) &optional colon at)

1142

(declare (ignore colon at))

1143

(let* ((year (duration-year object)) ; the first access so, to ensure decoding

1144

(month (spocq:duration-month object))

1145

(day (spocq:duration-day object))

1146

(hour (spocq:duration-hour object))

1147

(minute (spocq:duration-minute object))

1148

(second (spocq:duration-second object))

1149

(fraction (spocq:duration-fraction object))

1150

          (zero-duration (and (zerop year) (zerop month) (zerop day) (zerop minute) (zerop hour) (zerop second) (zerop fraction)))

1151

          (minus-duration (or (minusp year) (minusp month) (minusp day) (minusp hour) (minusp minute) (minusp second) (minusp fraction))))

1152

(cond (zero-duration

1153

(write-string "PT0S" stream))

1154

(t

1155

(format stream "~:[~;-~]P~@[~dY~]~@[~dM~]~@[~dD~]T~@[~dH~]~@[~dM~]~:[~@[~d~]~@[~a~]S~;~]"

1156

minus-duration

1157

(unless (zerop year) (abs year))

1158

(unless (zerop month) (abs month))

1159

(unless (zerop day) (abs day))

1160

(unless (zerop hour) (abs hour))

1161

(unless (zerop minute) (abs minute))

1162

(and (zerop second) (zerop fraction))

1163

(unless (and (zerop second) (zerop fraction)) (abs second))

1164

(unless (zerop fraction)

1165

                        (let* ((float (float (/ (abs fraction) +timeline-units-per-second+)))

1166

(string (format nil "~f" float)))

1167

(subseq string 1))))))))

1168

1169

(defgeneric |PnYnMnDTnHnMnS| (object)

1170

(:method ((object string))

1171

(let ((result (multiple-value-call #'make-duration (parse-|PnYnMnDTnHnMnS| object))))

1172

(setf (spocq:literal-lexical-form result) object)

1173

result))

1174

1175

(:method ((object spocq:duration))

1176

(or (spocq:literal-lexical-form object)

1177

(setf (spocq:literal-lexical-form object)

1178

;; generate a new lexical form, offset as per zone

1179

(with-output-to-string (stream) (spocq:format-duration stream object))))))

1180

1181

1182

(defun universal-time-duration (time)

1183

(multiple-value-bind (second minute hour day month year) (decode-universal-time time 0)

1184

     (spocq:make-duration :fraction 0 :second second :minute minute :hour hour :day day :month month :year year)))

1185

1186

(defun timeline-location-duration (location)

1187

   (multiple-value-bind (fraction second minute hour day month year) (dydra-ndk:decode-time location spocq:+reference-zone+)

1188

     (spocq:make-duration :fraction fraction :second second :minute minute :hour hour :day day :month month :year year)))

1189

1190

1191

(defun duration-timeline-location (duration)

1192

"Given a date-time, return the cached temporal value or compute it from the components."

1193

(or (spocq:temporal-timeline-location duration)

1194

(setf (spocq:temporal-timeline-location duration)

1195

(multiple-value-bind (fraction second minute hour day month year)

1196

(decode-duration duration)

1197

;; drop the zone

1198

(dydra-ndk::encode-time fraction second minute hour (1+ day) (1+ month)

1199

(+ year 1970)

1200

0)))))

1201

#+(or)

1202

(spocq:make-date-time :timeline-location (+ (duration-timeline-location (|PnYnMnDTnHnMnS| "P1DT0H0M0S"))

1203

                                             (date-time-timeline-location (|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| "1999-01-01T00:02:03Z"))))

1204

;;; (spocq:make-date-time :timeline-location 0)

1205

;;; (spocq:make-date-time :timeline-location (duration-timeline-location (|PnYnMnDTnHnMnS| "P0DT0H0M0S")))

1206

 ;;; (spocq:make-date-time :timeline-location (date-time-timeline-location (|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| "1999-01-01T24:02:03Z")))

1207

1208

(defmethod duration-month-location ((value spocq:duration))

1209

"Given a year-month-duration, return the cached location value or compute it from the components."

1210

(or (spocq:duration-month-location value)

1211

(multiple-value-bind (month-location second-location)

1212

                            (compute-duration-locations (spocq:duration-fraction (ensure-temporal-decoded value))

1213

                                                        (spocq:duration-second value)

1214

                                                        (spocq:duration-minute value)

1215

                                                        (spocq:duration-hour value)

1216

                                                        (spocq:duration-day value)

1217

                                                        (spocq:duration-month value)

1218

                                                        (spocq:duration-year value))

1219

(setf (spocq:duration-second-location value) second-location)

1220

(setf (spocq:duration-month-location value) month-location))))

1221

1222

(defmethod duration-second-location ((value spocq:duration))

1223

"Given a year-month-duration, return the cached location value or compute it from the components."

1224

(or (spocq:duration-second-location value)

1225

(multiple-value-bind (month-location second-location)

1226

                            (compute-duration-locations (spocq:duration-fraction (ensure-temporal-decoded value))

1227

                                                        (spocq:duration-second value)

1228

                                                        (spocq:duration-minute value)

1229

                                                        (spocq:duration-hour value)

1230

                                                        (spocq:duration-day value)

1231

                                                        (spocq:duration-month value)

1232

                                                        (spocq:duration-year value))

1233

(setf (spocq:duration-month-location value) month-location)

1234

(setf (spocq:duration-second-location value) second-location))))

1235

1236

1237

1238

;;;

1239

;;; g-day

1240

1241

(defun constrain-g-day-fragments (day zone)

1242

(constrain-temporal-fragments (day zone) |xsd|:|gDay|))

1243

1244

;;; no normalization

1245

;;; no canonicalization

1246

1247

(defun make-g-day (day &optional (zone spocq:+reference-zone+))

1248

   (encode-g-day spocq::+reference-fraction+ spocq:+reference-second+ spocq:+reference-minute+ spocq:+reference-hour+

1249

day spocq:+reference-month+ spocq:+reference-year+

1250

zone))

1251

1252

(defun encode-g-day (fraction second minute hour day month year &optional zone)

1253

"Given all temporal fragments, construct a g-day from the constrained, canonicalized values."

1254

(constrain-temporal-fragments (year month day hour minute) |xsd|:|gDay|)

1255

(when (offset-zone-p zone)

1256

(multiple-value-setq (fraction second minute hour day month year)

1257

       (canonicalize-date-time-fragments fraction second minute hour day month year zone spocq:+reference-zone+)))

1258

(spocq:make-g-day :minute minute :hour hour :day day :month month :year year :zone zone))

1259

1260

1261

1262

(defun parse-|---dd(ZZZZZZ)?| (string)

1263

(handler-case

1264

(multiple-value-bind (match substrings)

1265

                          (cl-ppcre:scan-to-strings (load-time-value (cl-ppcre:create-scanner "^---([0-9][0-9])(([zZ])|([+-])([0-9][0-9]):([0-9][0-9]))?$"))

1266

string)

1267

(assert match () "invalid gDay lexical form")

1268

(let* ((day (parse-integer (aref substrings 0))))

1269

(if (aref substrings 1)

1270

(if (aref substrings 2)

1271

(values day spocq:+reference-zone+)

1272

(let* ((zone-sign (aref substrings 3))

1273

(zone-hours (aref substrings 4))

1274

(zone-minutes (aref substrings 5)))

1275

(values day (* (if (equal zone-sign "-") -1 1)

1276

(+ (parse-integer zone-hours)

1277

(/ (parse-integer zone-minutes) 60))))))

1278

(values day nil))))

1279

(error ()

1280

(invalid-argument-type |xsd|:|gDay| string |xsd|:|gDay|))))

1281

1282

(defmethod temporal-decoded-p ((term spocq:g-day))

1283

(not (null (spocq:g-day-day term))))

1284

1285

(defgeneric decode-g-day (value)

1286

1287

(:method ((value spocq:g-day))

1288

(let ((day (spocq:g-day-day value)))

1289

(if day

1290

(values spocq:+reference-fraction+

1291

spocq:+reference-second+

1292

(spocq:g-day-minute value)

1293

(spocq:g-day-hour value)

1294

day

1295

spocq:+reference-month+

1296

spocq:+reference-year+

1297

(spocq:g-day-zone value))

1298

(flet ((update-fragments (fraction second minute hour day month year zone)

1299

;; nb.!!! the lexical form can end up out-of-sync with the fragments

1300

(values fraction

1301

(setf (spocq:g-day-second value) second)

1302

(setf (spocq:g-day-minute value) minute)

1303

(setf (spocq:g-day-hour value) hour)

1304

(setf (spocq:g-day-day value) day)

1305

(setf (spocq:g-day-month value) month)

1306

(setf (spocq:g-day-year value) year)

1307

(setf (spocq:g-day-zone value) zone))))

1308

(let ((location (spocq:temporal-timeline-location value)))

1309

(if location

1310

(multiple-value-call #'update-fragments (decode-g-day location))

1311

(let ((lexical-form (spocq:literal-lexical-form value)))

1312

(if lexical-form

1313

(multiple-value-call #'update-fragments (decode-g-day lexical-form))

1314

(error "Invalid g-day: ~s" value)))))))))

1315

1316

(:method ((location integer))

1317

"Given a location, parse it and return the fragments. Pin the zone."

1318

(multiple-value-bind (fraction second minute hour day month year)

1319

(dydra-ndk::decode-time location spocq:+reference-zone+)

1320

(values fraction second minute hour day month year spocq:+reference-zone+)))

1321

1322

(:method ((lexical-form string))

1323

     "Given a g-day lexical form string, parse it, constrain, then canonicalize, then return the frgments.

1324

No normalization happens, as the lexical contraints proscribe such values."

1325

(multiple-value-bind (day zone)

1326

                          (multiple-value-call #'constrain-g-day-fragments (parse-|---dd(ZZZZZZ)?| lexical-form))

1327

(let ((fraction spocq::+reference-fraction+)

1328

(second spocq:+reference-second+)

1329

(minute spocq:+reference-minute+)

1330

(hour spocq:+reference-hour+)

1331

(month spocq:+reference-month+)

1332

(year spocq:+reference-year+))

1333

(when (offset-zone-p zone)

1334

(multiple-value-setq (fraction second minute hour day month year)

1335

             (canonicalize-date-time-fragments fraction second minute hour day month year zone spocq:+reference-zone+)))

1336

(values fraction second minute hour day month year zone)))))

1337

 (declaim (ftype (function ((or spocq:g-day string integer)) (values fixnum fixnum fixnum fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) decode-g-day))

1338

1339

 (defmethod spocq:format-g-day (stream (object spocq:g-day) &optional expand-zulu-p offset-zone-p (zone (g-day-zone object)))

1340

(multiple-value-bind (fraction second minute hour day month year) (decode-g-day object)

1341

(when (and offset-zone-p (offset-zone-p zone))

1342

(multiple-value-setq (fraction second minute hour day month year)

1343

         (canonicalize-date-time-fragments fraction second minute hour day month year spocq:+reference-zone+ zone)))

1344

(format stream "---~2,'0d" day)

1345

(spocq:format-zone-offset stream (if offset-zone-p zone spocq:+reference-zone+) expand-zulu-p)))

1346

1347

1348

(defgeneric |---dd(ZZZZZZ)?| (object)

1349

(:method ((object string))

1350

(multiple-value-bind (fraction second minute hour day month year zone)

1351

(decode-g-day object)

1352

(declare (ignore fraction second))

1353

(spocq:make-g-day :minute minute :hour hour :day day :month month :year year

1354

:zone zone :lexical-form object)))

1355

1356

(:method ((object spocq:g-day))

1357

(or (spocq:literal-lexical-form object)

1358

(setf (spocq:literal-lexical-form object)

1359

(with-output-to-string (stream) (spocq:format-g-day stream object nil t))))))

1360

1361

;;; (|---dd(ZZZZZZ)?| (|---dd(ZZZZZZ)?| "---12"))

1362

;;; (|---dd(ZZZZZZ)?| (|---dd(ZZZZZZ)?| "---12Z"))

1363

;;; (|---dd(ZZZZZZ)?| (|---dd(ZZZZZZ)?| "---12+12:00"))

1364

;;; (|---dd(ZZZZZZ)?| (|---dd(ZZZZZZ)?| "---01-12:00"))

1365

1366

1367

;;;

1368

;;; g-month

1369

1370

(defun constrain-g-month-fragments (month zone)

1371

(constrain-temporal-fragments (month zone) |xsd|:|gMonth|))

1372

1373

;;; no normalization

1374

;;; no canonicalization

1375

1376

(defun make-g-month (month &optional (zone spocq:+reference-zone+))

1377

   (encode-g-month spocq::+reference-fraction+ spocq:+reference-second+ spocq:+reference-minute+ spocq:+reference-hour+

1378

spocq:+reference-day+ month spocq:+reference-year+

1379

zone))

1380

1381

(defun encode-g-month (fraction second minute hour day month year &optional zone)

1382

"Given all temporal fragments, construct a g-month from the constrained, canonicalized value."

1383

(constrain-temporal-fragments (year month day hour minute) |xsd|:|gMonth|)

1384

(when (offset-zone-p zone)

1385

(multiple-value-setq (fraction second minute hour day month year)

1386

       (canonicalize-date-time-fragments fraction second minute hour day month year zone spocq:+reference-zone+)))

1387

(spocq:make-g-month :minute minute :hour hour :day day :month month :year year :zone zone))

1388

1389

1390

1391

(defun parse-|--MM(ZZZZZZ)?| (string)

1392

(handler-case

1393

(multiple-value-bind (match substrings)

1394

                          (cl-ppcre:scan-to-strings (load-time-value (cl-ppcre:create-scanner "^--([0-9][0-9])(([zZ])|([+-])([0-9][0-9]):([0-9][0-9]))?$"))

1395

string)

1396

(assert match () "invalid gMonth lexical form")

1397

(let* ((month (parse-integer (aref substrings 0))))

1398

(assert (<= 1 month 12))

1399

(if (aref substrings 1)

1400

(if (aref substrings 2)

1401

(values month 0)

1402

(let* ((zone-sign (aref substrings 3))

1403

(zone-hours (aref substrings 4))

1404

(zone-minutes (aref substrings 5)))

1405

(values month (* (if (equal zone-sign "-") -1 1)

1406

(+ (parse-integer zone-hours)

1407

(/ (parse-integer zone-minutes) 60))))))

1408

(values month nil))))

1409

(error ()

1410

(invalid-argument-type |xsd|:|gMonth| string |xsd|:|gMonth|))))

1411

1412

1413

(defmethod temporal-decoded-p ((term spocq:g-month))

1414

(not (null (spocq:g-month-month term))))

1415

1416

(defgeneric decode-g-month (value)

1417

   (:documentation "Given a g-month, return the month and zone fragments complemented with reference fragments")

1418

1419

(:method ((value spocq:g-month))

1420

(let ((month (spocq:g-month-month value)))

1421

(if month

1422

(values spocq::+reference-fraction+ spocq:+reference-second+

1423

(spocq:g-month-minute value)

1424

(spocq:g-month-hour value)

1425

(spocq:g-month-day value)

1426

month

1427

spocq:+reference-year+

1428

(spocq:g-month-zone value))

1429

(flet ((update-fragments (fraction second minute hour day month year zone)

1430

;; nb.!!! the lexical form can end up out-of-sync with the fragments

1431

(values fraction

1432

(setf (spocq:g-month-second value) second)

1433

(setf (spocq:g-month-minute value) minute)

1434

(setf (spocq:g-month-hour value) hour)

1435

(setf (spocq:g-month-day value) day)

1436

(setf (spocq:g-month-month value) month)

1437

(setf (spocq:g-month-year value) year)

1438

(setf (spocq:g-month-zone value) zone))))

1439

(let ((location (spocq:temporal-timeline-location value)))

1440

(if location

1441

(multiple-value-call #'update-fragments (decode-g-month location))

1442

(let ((lexical-form (spocq:literal-lexical-form value)))

1443

(if lexical-form

1444

(multiple-value-call #'update-fragments (decode-g-month lexical-form))

1445

(error "Invalid g-month: ~s" value)))))))))

1446

1447

(:method ((location integer))

1448

"Given a location, parse it and return the fragments. Pin the zone."

1449

(multiple-value-bind (fraction second minute hour day month year)

1450

(dydra-ndk::decode-time location spocq:+reference-zone+)

1451

(values fraction second minute hour day month year spocq:+reference-zone+)))

1452

1453

(:method ((lexical-form string))

1454

     "Given a g-month lexical form string, parse it, constrain, then canonicalize, then return the frgments.

1455

No normalization happens, as the lexical contraints proscribe such values."

1456

(multiple-value-bind (month zone)

1457

                          (multiple-value-call #'constrain-g-month-fragments (parse-|--MM(ZZZZZZ)?| lexical-form))

1458

(let ((fraction spocq::+reference-fraction+)

1459

(second spocq:+reference-second+)

1460

(minute spocq:+reference-minute+)

1461

(hour spocq:+reference-hour+)

1462

(day spocq:+reference-day+)

1463

(year spocq:+reference-year+))

1464

(when (offset-zone-p zone)

1465

(multiple-value-setq (fraction second minute hour day month year)

1466

             (canonicalize-date-time-fragments fraction second minute hour day month year zone spocq:+reference-zone+)))

1467

(values fraction second minute hour day month year zone)))))

1468

 (declaim (ftype (function ((or spocq:g-month string integer)) (values fixnum fixnum fixnum fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) decode-g-month))

1469

1470

 (defmethod spocq:format-g-month (stream (object spocq:g-month) &optional expand-zulu-p offset-zone-p (zone (g-month-zone object)))

1471

(multiple-value-bind (fraction second minute hour day month year) (decode-g-month object)

1472

(when (and offset-zone-p (offset-zone-p zone))

1473

(multiple-value-setq (fraction second minute hour day month year)

1474

         (canonicalize-date-time-fragments fraction second minute hour day month year spocq:+reference-zone+ zone)))

1475

(format stream "--~2,'0d" month)

1476

(spocq:format-zone-offset stream (if offset-zone-p zone spocq:+reference-zone+) expand-zulu-p)))

1477

1478

1479

(defgeneric |--MM(ZZZZZZ)?| (object)

1480

(:method ((object string))

1481

(multiple-value-bind (fraction second minute hour day month year zone)

1482

(decode-g-month object)

1483

(declare (ignore fraction second))

1484

(spocq:make-g-month :minute minute :hour hour :day day :month month :year year

1485

:zone zone :lexical-form object)))

1486

1487

(:method ((object spocq:g-month))

1488

(or (spocq:literal-lexical-form object)

1489

(setf (spocq:literal-lexical-form object)

1490

(with-output-to-string (stream) (spocq:format-g-month stream object nil t))))))

1491

1492

;;; (|--MM(ZZZZZZ)?| (|--MM(ZZZZZZ)?| "--12"))

1493

;;; (|--MM(ZZZZZZ)?| (|--MM(ZZZZZZ)?| "--12Z"))

1494

;;; (|--MM(ZZZZZZ)?| (|--MM(ZZZZZZ)?| "--02-13:30"))

1495

1496

1497

;;;

1498

;;; g-month-day

1499

1500

(defun constrain-g-month-day-fragments (day month zone)

1501

(constrain-temporal-fragments (day month zone) |xsd|:|gMonthDay|))

1502

1503

;;; no normalization

1504

;;; no canonicalization

1505

1506

(defun make-g-month-day (day month &optional (zone spocq:+reference-zone+))

1507

   (encode-g-month-day spocq::+reference-fraction+ spocq:+reference-second+ spocq:+reference-minute+ spocq:+reference-hour+

1508

day month spocq:+reference-year+

1509

zone))

1510

1511

(defun encode-g-month-day (fraction second minute hour day month year &optional zone)

1512

"Given all temporal fragments, construct a g-month-day from the constrained, canonicalized values."

1513

(constrain-temporal-fragments (year month day hour minute) |xsd|:|gMonthDay|)

1514

(when (offset-zone-p zone)

1515

(multiple-value-setq (fraction second minute hour day month year)

1516

       (canonicalize-date-time-fragments fraction second minute hour day month year zone spocq:+reference-zone+)))

1517

(spocq:make-g-month-day :minute minute :hour hour :day day :month month :year year :zone zone))

1518

1519

1520

(defun parse-|--MM-dd(ZZZZZZ)?| (string)

1521

(handler-case

1522

(multiple-value-bind (match substrings)

1523

                            (cl-ppcre:scan-to-strings (load-time-value (cl-ppcre:create-scanner "^--([0-9][0-9])-([0-9][0-9])(([zZ])|([+-])([0-9][0-9]):([0-9][0-9]))?$"))

1524

string)

1525

(assert match () "invalid gMonthDay lexical form")

1526

(let* ((month (parse-integer (aref substrings 0)))

1527

(day (parse-integer (aref substrings 1))))

1528

(if (aref substrings 2)

1529

(if (aref substrings 3)

1530

(values day month spocq:+reference-zone+)

1531

(let* ((zone-sign (aref substrings 4))

1532

(zone-hours (aref substrings 5))

1533

(zone-minutes (aref substrings 6)))

1534

(values day month

1535

(* (if (equal zone-sign "-") -1 1)

1536

(+ (parse-integer zone-hours)

1537

(/ (parse-integer zone-minutes) 60))))))

1538

(values day month nil))))

1539

(error ()

1540

(invalid-argument-type |xsd|:|gMonthDay| string |xsd|:|gMonthDay|))))

1541

1542

1543

(defmethod temporal-decoded-p ((term spocq:g-month-day))

1544

(not (null (spocq:g-month-day-day term))))

1545

1546

(defgeneric decode-g-month-day (value)

1547

   (:documentation "Given a g-month-day, return the month, day and zone fragments complemented with reference fragments")

1548

1549

(:method ((value spocq:g-month-day))

1550

(let ((day (spocq:g-month-day-day value)))

1551

(if day

1552

(values spocq:+reference-fraction+

1553

spocq:+reference-second+

1554

(spocq:g-month-day-minute value)

1555

(spocq:g-month-day-hour value)

1556

day

1557

(spocq:g-month-day-month value)

1558

(spocq:g-month-day-year value)

1559

(spocq:g-month-day-zone value))

1560

(flet ((update-fragments (fraction second minute hour day month year zone)

1561

;; nb.!!! the lexical form can end up out-of-sync with the fragments

1562

(values fraction

1563

(setf (spocq:g-month-day-second value) second)

1564

(setf (spocq:g-month-day-minute value) minute)

1565

(setf (spocq:g-month-day-hour value) hour)

1566

(setf (spocq:g-month-day-day value) day)

1567

(setf (spocq:g-month-day-month value) month)

1568

(setf (spocq:g-month-day-year value) year)

1569

(setf (spocq:g-month-day-zone value) zone))))

1570

(let ((location (spocq:temporal-timeline-location value)))

1571

(if location

1572

(multiple-value-call #'update-fragments (decode-g-month-day location))

1573

(let ((lexical-form (spocq:literal-lexical-form value)))

1574

(if lexical-form

1575

(multiple-value-call #'update-fragments (decode-g-month-day lexical-form))

1576

(error "Invalid g-month-day: ~s" value)))))))))

1577

1578

(:method ((location integer))

1579

"Given a location, parse it and return the fragments. Pin the zone."

1580

(multiple-value-bind (fraction second minute hour day month year)

1581

(dydra-ndk::decode-time location spocq:+reference-zone+)

1582

(values fraction second minute hour day month year spocq:+reference-zone+)))

1583

1584

(:method ((lexical-form string))

1585

     "Given a g-month-day lexical form string, parse it, constrain, then canonicalize, then return the frgments.

1586

No normalization happens, as the lexical contraints proscribe such values."

1587

(multiple-value-bind (day month zone)

1588

                          (multiple-value-call #'constrain-g-month-day-fragments (parse-|--MM-dd(ZZZZZZ)?| lexical-form))

1589

(let ((fraction spocq::+reference-fraction+)

1590

(second spocq:+reference-second+)

1591

(minute spocq:+reference-minute+)

1592

(hour spocq:+reference-hour+)

1593

(year spocq:+reference-year+))

1594

(when (offset-zone-p zone)

1595

(multiple-value-setq (fraction second minute hour day month year)

1596

             (canonicalize-date-time-fragments fraction second minute hour day month year zone spocq:+reference-zone+)))

1597

(values fraction second minute hour day month year zone)))))

1598

 (declaim (ftype (function ((or spocq:g-month-day string integer)) (values fixnum fixnum fixnum fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) decode-g-month-day))

1599

1600

1601

 (defmethod spocq:format-g-month-day (stream (object spocq:g-month-day) &optional expand-zulu-p offset-zone-p (zone (g-month-day-zone object)))

1602

(multiple-value-bind (fraction second minute hour day month year) (decode-g-month-day object)

1603

(when (and offset-zone-p (offset-zone-p zone))

1604

(multiple-value-setq (fraction second minute hour day month year)

1605

         (canonicalize-date-time-fragments fraction second minute hour day month year spocq:+reference-zone+ zone)))

1606

(format stream "--~2,'0d-~2,'0d" month day)

1607

(spocq:format-zone-offset stream (if offset-zone-p zone spocq:+reference-zone+) expand-zulu-p)))

1608

1609

1610

(defgeneric |--MM-dd(ZZZZZZ)?| (object)

1611

(:method ((object string))

1612

(multiple-value-bind (fraction second minute hour day month year zone)

1613

(decode-g-month-day object)

1614

(declare (ignore fraction second))

1615

(spocq:make-g-month-day :minute minute :hour hour :day day :month month :year year

1616

:zone zone :lexical-form object)))

1617

1618

(:method ((object spocq:g-month-day))

1619

(or (spocq:literal-lexical-form object)

1620

(setf (spocq:literal-lexical-form object)

1621

(with-output-to-string (stream) (spocq:format-g-month-day stream object nil t))))))

1622

1623

1624

;;; (|--MM-dd(ZZZZZZ)?| (|--MM-dd(ZZZZZZ)?| "--12-31"))

1625

;;; (|--MM-dd(ZZZZZZ)?| (|--MM-dd(ZZZZZZ)?| "--12-31Z"))

1626

;;; (|--MM-dd(ZZZZZZ)?| (|--MM-dd(ZZZZZZ)?| "--12-31-03:30"))

1627

1628

1629

1630

;;;

1631

;;; g-year

1632

1633

(defun constrain-g-year-fragments (year zone)

1634

(constrain-temporal-fragments (year zone) |xsd|:|gYear|))

1635

1636

;;; no normalization

1637

;;; no canonicalization

1638

1639

(defun make-g-year (year &optional (zone spocq:+reference-zone+))

1640

   (encode-g-year spocq::+reference-fraction+ spocq:+reference-second+ spocq:+reference-minute+ spocq:+reference-hour+

1641

spocq:+reference-day+ spocq:+reference-month+ year

1642

zone))

1643

1644

1645

(defun encode-g-year (fraction second minute hour day month year &optional zone)

1646

"Given all temporal fragments, construct a g-year from the constrained, canonicalized value."

1647

(constrain-temporal-fragments (year month day hour minute) |xsd|:|gYear|)

1648

(when (offset-zone-p zone)

1649

(multiple-value-setq (fraction second minute hour day month year)

1650

       (canonicalize-date-time-fragments fraction second minute hour day month year zone spocq:+reference-zone+)))

1651

(spocq:make-g-year :minute minute :hour hour :day day :month month :year year :zone zone))

1652

1653

1654

1655

(defun parse-|YYYY(ZZZZZZ)?| (string)

1656

(handler-case

1657

(multiple-value-bind (match substrings)

1658

                            (cl-ppcre:scan-to-strings (load-time-value (cl-ppcre:create-scanner "^([0-9][0-9][0-9][0-9]+)(([zZ])|([+-])([0-9][0-9]):([0-9][0-9]))?$"))

1659

string)

1660

(assert match () "invalid gYearMonth lexical form")

1661

(let* ((year (parse-integer (aref substrings 0))))

1662

(if (aref substrings 1)

1663

(if (aref substrings 2)

1664

(values year spocq:+reference-zone+)

1665

(let* ((zone-sign (aref substrings 3))

1666

(zone-hours (aref substrings 4))

1667

(zone-minutes (aref substrings 5)))

1668

(values year (* (if (equal zone-sign "-") -1 1)

1669

(+ (parse-integer zone-hours)

1670

(/ (parse-integer zone-minutes) 60))))))

1671

(values year nil))))

1672

(error ()

1673

(invalid-argument-type |xsd|:|gYear| string |xsd|:|gYear|))))

1674

1675

1676

(defmethod temporal-decoded-p ((term spocq:g-year))

1677

(not (null (spocq:g-year-year term))))

1678

1679

(defgeneric decode-g-year (value)

1680

   (:documentation "Given a g-year, return the year and zone fragments complemented with reference fragments")

1681

1682

(:method ((value spocq:g-year))

1683

(let ((year (spocq:g-year-year value)))

1684

(if year

1685

(values spocq::+reference-fraction+ spocq:+reference-second+

1686

(spocq:g-year-minute value)

1687

(spocq:g-year-hour value)

1688

(spocq:g-year-day value)

1689

(spocq:g-year-month value)

1690

year

1691

(spocq:g-year-zone value))

1692

(flet ((update-fragments (fraction second minute hour day month year zone)

1693

;; nb.!!! the lexical form can end up out-of-sync with the fragments

1694

(values fraction

1695

(setf (spocq:g-year-second value) second)

1696

(setf (spocq:g-year-minute value) minute)

1697

(setf (spocq:g-year-hour value) hour)

1698

(setf (spocq:g-year-day value) day)

1699

(setf (spocq:g-year-month value) month)

1700

(setf (spocq:g-year-year value) year)

1701

(setf (spocq:g-year-zone value) zone))))

1702

(let ((location (spocq:temporal-timeline-location value)))

1703

(if location

1704

(multiple-value-call #'update-fragments (decode-g-year location))

1705

(let ((lexical-form (spocq:literal-lexical-form value)))

1706

(if lexical-form

1707

(multiple-value-call #'update-fragments (decode-g-year lexical-form))

1708

(error "Invalid g-year: ~s" value)))))))))

1709

1710

(:method ((location integer))

1711

"Given a location, parse it and return the fragments. Pin the zone."

1712

(multiple-value-bind (fraction second minute hour day month year)

1713

(dydra-ndk::decode-time location spocq:+reference-zone+)

1714

(values fraction second minute hour day month year spocq:+reference-zone+)))

1715

1716

(:method ((lexical-form string))

1717

     "Given a g-year lexical form string, parse it, constrain, then canonicalize, then return the frgments.

1718

No normalization happens, as the lexical contraints proscribe such values."

1719

(multiple-value-bind (year zone)

1720

                          (multiple-value-call #'constrain-g-year-fragments (parse-|YYYY(ZZZZZZ)?| lexical-form))

1721

(let ((fraction spocq::+reference-fraction+)

1722

(second spocq:+reference-second+)

1723

(minute spocq:+reference-minute+)

1724

(hour spocq:+reference-hour+)

1725

(day spocq:+reference-day+)

1726

(month spocq:+reference-month+))

1727

(when (offset-zone-p zone)

1728

(multiple-value-setq (fraction second minute hour day month year)

1729

             (canonicalize-date-time-fragments fraction second minute hour day month year zone spocq:+reference-zone+)))

1730

(values fraction second minute hour day month year zone)))))

1731

 (declaim (ftype (function ((or spocq:g-year string integer)) (values fixnum fixnum fixnum fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) decode-g-year))

1732

1733

1734

 (defmethod spocq:format-g-year (stream (object spocq:g-year) &optional expand-zulu-p offset-zone-p (zone (g-year-zone object)))

1735

(multiple-value-bind (fraction second minute hour day month year) (decode-g-year object)

1736

(when (and offset-zone-p (offset-zone-p zone))

1737

(multiple-value-setq (fraction second minute hour day month year)

1738

         (canonicalize-date-time-fragments fraction second minute hour day month year spocq:+reference-zone+ zone)))

1739

(format stream "~4,'0d" year)

1740

(spocq:format-zone-offset stream (if offset-zone-p zone spocq:+reference-zone+) expand-zulu-p)))

1741

1742

1743

(defgeneric |YYYY(ZZZZZZ)?| (object)

1744

(:method ((object string))

1745

(multiple-value-bind (fraction second minute hour day month year zone)

1746

(decode-g-year object)

1747

(declare (ignore fraction second))

1748

(spocq:make-g-year :minute minute :hour hour :day day :month month :year year

1749

:zone zone :lexical-form object)))

1750

1751

(:method ((object spocq:g-year))

1752

(or (spocq:literal-lexical-form object)

1753

(setf (spocq:literal-lexical-form object)

1754

(with-output-to-string (stream) (spocq:format-g-year stream object nil t))))))

1755

1756

;;; (|YYYY(ZZZZZZ)?| (|YYYY(ZZZZZZ)?| "1995"))

1757

;;; (|YYYY(ZZZZZZ)?| (|YYYY(ZZZZZZ)?| "201111"))

1758

;;; (|YYYY(ZZZZZZ)?| (|YYYY(ZZZZZZ)?| "1995Z"))

1759

;;; (|YYYY(ZZZZZZ)?| (|YYYY(ZZZZZZ)?| "1995-03:30"))

1760

1761

1762

1763

;;;

1764

;;; g-year-month

1765

1766

(defun constrain-g-year-month-fragments (month year zone)

1767

(constrain-temporal-fragments (month year zone) |xsd|:|gYearMonth|))

1768

1769

;;; no canonicalization, as no zone is present

1770

1771

(defun make-g-year-month (month year &optional (zone spocq:+reference-zone+))

1772

   (encode-g-year-month spocq::+reference-fraction+ spocq:+reference-second+ spocq:+reference-minute+ spocq:+reference-hour+

1773

spocq:+reference-day+ month year

1774

zone))

1775

1776

1777

(defun encode-g-year-month (fraction second minute hour day month year &optional (zone 0))

1778

"Given all temporal fragments, construct a g-year-month from the constrained, canonicalized values.

1779

The fragments fraction and second, if any, are ignored, as they do not apply."

1780

(constrain-temporal-fragments (year month day hour minute) |xsd|:|gYearMonth|)

1781

(when (offset-zone-p zone)

1782

(multiple-value-setq (fraction second minute hour day month year)

1783

       (canonicalize-date-time-fragments fraction second minute hour day month year zone spocq:+reference-zone+)))

1784

(spocq:make-g-year-month :minute minute :hour hour :day day :month month :year year :zone zone))

1785

1786

1787

1788

(defun parse-|YYYY-MM(ZZZZZZ)?| (string)

1789

(handler-case

1790

(multiple-value-bind (match substrings)

1791

                            (cl-ppcre:scan-to-strings (load-time-value (cl-ppcre:create-scanner "^([0-9][0-9][0-9][0-9]+)-([0-9][0-9])(([zZ])|([+-])([0-9][0-9]):([0-9][0-9]))?$"))

1792

string)

1793

(assert match () "invalid gYearMonth lexical form")

1794

(let* ((year (parse-integer (aref substrings 0)))

1795

(month (parse-integer (aref substrings 1))))

1796

(if (aref substrings 2)

1797

(if (aref substrings 3)

1798

(values month year spocq:+reference-zone+)

1799

(let* ((zone-sign (aref substrings 4))

1800

(zone-hours (aref substrings 5))

1801

(zone-minutes (aref substrings 6)))

1802

(values month year (* (if (equal zone-sign "-") -1 1)

1803

                                             (+ (parse-integer zone-hours)

1804

                                                (/ (parse-integer zone-minutes) 60))))))

1805

(values month year nil))))

1806

(error ()

1807

(invalid-argument-type |xsd|:|gYearMonth| string |xsd|:|gYearMonth|))))

1808

1809

1810

(defmethod temporal-decoded-p ((term spocq:g-year-month))

1811

(not (null (spocq:g-year-month-year term))))

1812

1813

(defgeneric decode-g-year-month (value)

1814

   (:documentation "GIven a g-year-month return the temporal fragments - including the minute and hour which may result form the zone offset" )

1815

1816

(:method ((value spocq:g-year-month))

1817

(let ((year (spocq:g-year-month-year value)))

1818

(if year

1819

(values spocq:+reference-fraction+ spocq:+reference-second+

1820

(spocq:g-year-month-minute value)

1821

(spocq:g-year-month-hour value)

1822

(spocq:g-year-month-day value)

1823

(spocq:g-year-month-month value)

1824

year

1825

(spocq:g-year-month-zone value))

1826

(flet ((update-fragments (fraction second minute hour day month year zone)

1827

;; nb.!!! the lexical form can end up out-of-sync with the fragments

1828

(values fraction

1829

(setf (spocq:g-year-month-second value) second)

1830

(setf (spocq:g-year-month-minute value) minute)

1831

(setf (spocq:g-year-month-hour value) hour)

1832

(setf (spocq:g-year-month-day value) day)

1833

(setf (spocq:g-year-month-month value) month)

1834

(setf (spocq:g-year-month-year value) year)

1835

(setf (spocq:g-year-month-zone value) zone))))

1836

(let ((location (spocq:temporal-timeline-location value)))

1837

(if location

1838

(multiple-value-call #'update-fragments (decode-g-year-month location))

1839

(let ((lexical-form (spocq:literal-lexical-form value)))

1840

(if lexical-form

1841

(multiple-value-call #'update-fragments (decode-g-year-month lexical-form))

1842

(error "Invalid g-year-month: ~s" value)))))))))

1843

1844

(:method ((location integer))

1845

"Given a location, parse it and return the fragments. Pin the zone."

1846

(multiple-value-bind (fraction second minute hour day month year)

1847

(dydra-ndk::decode-time location spocq:+reference-zone+)

1848

(values fraction second minute hour day month year spocq:+reference-zone+)))

1849

1850

(:method ((lexical-form string))

1851

"Given a lexical form string, parse it, constrain, then canonicalize, then return.

1852

No normalization happens, as the lexical contraints proscribe such values."

1853

(multiple-value-bind (month year zone)

1854

                          (multiple-value-call #'constrain-g-year-month-fragments (parse-|YYYY-MM(ZZZZZZ)?| lexical-form))

1855

(let ((fraction spocq::+reference-fraction+)

1856

(second spocq:+reference-second+)

1857

(minute spocq:+reference-minute+)

1858

(hour spocq:+reference-hour+)

1859

(day spocq:+reference-day+))

1860

(when (offset-zone-p zone)

1861

(multiple-value-setq (fraction second minute hour day month year)

1862

             (canonicalize-date-time-fragments fraction second minute hour day month year zone 0)))

1863

(values fraction second minute hour day month year zone)))))

1864

 (declaim (ftype (function ((or spocq:g-year-month string integer)) (values fixnum fixnum fixnum fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) decode-g-year-month))

1865

1866

1867

 (defmethod spocq:format-g-year-month (stream (object spocq:g-year-month) &optional expand-zulu-p offset-zone-p (zone (g-year-month-zone object)))

1868

(multiple-value-bind (fraction second minute hour day month year) (decode-g-year-month object)

1869

(when (and offset-zone-p (offset-zone-p zone))

1870

(multiple-value-setq (fraction second minute hour day month year)

1871

         (canonicalize-date-time-fragments fraction second minute hour day month year spocq:+reference-zone+ zone)))

1872

(format stream "~4,'0d-~2,'0d" year month)

1873

(spocq:format-zone-offset stream (if offset-zone-p zone spocq:+reference-zone+) expand-zulu-p)))

1874

1875

1876

(defgeneric |YYYY-MM(ZZZZZZ)?| (object)

1877

(:method ((object string))

1878

(multiple-value-bind (fraction second minute hour day month year zone)

1879

(decode-g-year-month object)

1880

(declare (ignore fraction second))

1881

(spocq:make-g-year-month :minute minute :hour hour :day day :month month :year year

1882

:zone zone :lexical-form object)))

1883

1884

(:method ((object spocq:g-year-month))

1885

(or (spocq:literal-lexical-form object)

1886

(setf (spocq:literal-lexical-form object)

1887

(with-output-to-string (stream) (spocq:format-g-year-month stream object nil t))))))

1888

1889

;;; (|YYYY-MM(ZZZZZZ)?| (|YYYY-MM(ZZZZZZ)?| "1995-12"))

1890

;;; (|YYYY-MM(ZZZZZZ)?| (|YYYY-MM(ZZZZZZ)?| "201111-12"))

1891

;;; (|YYYY-MM(ZZZZZZ)?| (|YYYY-MM(ZZZZZZ)?| "1995-12Z"))

1892

;;; (|YYYY-MM(ZZZZZZ)?| (|YYYY-MM(ZZZZZZ)?| "1995-12-03:30"))

1893

1894

1895

;;;

1896

;;; intervals

1897

1898

(defparameter *temporal-interval-scanner*

1899

(cl-ppcre:create-scanner `(:sequence :start-anchor

1900

                                        (:register (:non-greedy-repetition 0 nil :EVERYTHING))

1901

(:alternation " - " "/" "--")

1902

                                        (:register (:non-greedy-repetition 0 nil :EVERYTHING))

1903

:end-anchor)))

1904

1905

(defun scan-temporal-interval-string (string)

1906

(cl-ppcre:scan-to-strings *temporal-interval-scanner* string))

1907

1908

(defmethod term-lexical-form ((interval spocq:interval))

1909

(format nil "~a/~a" ;; iso : https://en.wikipedia.org/wiki/ISO_8601#Time_intervals

1910

(term-lexical-form (spocq:interval-start interval))

1911

(term-lexical-form (spocq:interval-end interval))))

1912

1913

(defgeneric |time|:|dateInterval| (lexical-form)

1914

(:method ((lexical-form string))

1915

(multiple-value-bind (match elements) (scan-temporal-interval-string lexical-form)

1916

(if match

1917

(spocq:make-date-interval :start (|-yyyy-MM-dd(ZZZZ)?| (aref elements 0))

1918

                                     :end (|-yyyy-MM-dd(ZZZZ)?| (aref elements 1))

1919

:lexical-form lexical-form)

1920

(error "Invalid date-interval: ~s" lexical-form))))

1921

(:method ((interval spocq:date-interval))

1922

interval))

1923

;;; (|time|:|DateInterval| "2019-01-02/2019-01-03")

1924

;;; (|time|:|DateInterval| "2019-01-02--2019-01-03")

1925

;;; (|time|:|DateInterval| "2019-01-02 - 2019-01-03")

1926

1927

(defgeneric |time|:|dateTimeInterval| (datum)

1928

(:method ((lexical-form string))

1929

(multiple-value-bind (match elements) (scan-temporal-interval-string lexical-form)

1930

(if match

1931

(spocq:make-date-time-interval :start (|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| (aref elements 0))

1932

                                          :end (|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| (aref elements 1))

1933

:lexical-form lexical-form)

1934

(error "Invalid date-time-interval: ~s" lexical-form))))

1935

(:method ((interval spocq:date-time-interval))

1936

interval))

1937

;;; (|time|:|DateTimeInterval| "2019-01-02T00:01:02/2019-01-03T03:04:05")

1938

1939

(defgeneric |time|:|timeInterval| (datum)

1940

(:method ((lexical-form string))

1941

(multiple-value-bind (match elements) (scan-temporal-interval-string lexical-form)

1942

(if match

1943

(spocq:make-time-interval :start (|HH:mm:ss(ZZZZ)?| (aref elements 0))

1944

:end (|HH:mm:ss(ZZZZ)?| (aref elements 1))

1945

:lexical-form lexical-form)

1946

(error "Invalid time-interval: ~s" lexical-form))))

1947

(:method ((interval spocq:time-interval))

1948

interval))

1949

;;; (|time|:|TimeInterval| "00:01:02/00:03:04")

1950

1951

1952

;;; encoding for revision intervals (aka versions)

1953

1954

(defmethod term-lexical-form ((interval spocq:revision-interval))

1955

(format nil "~a/~a" ;; iso : https://en.wikipedia.org/wiki/ISO_8601#Time_intervals

1956

(term-lexical-form (revision-interval-start-date-time interval))

1957

(term-lexical-form (revision-interval-end-date-time interval))))

1958

1959

(defgeneric revision-interval-end-date-time (interval)

1960

(:method ((object t))

1961

nil)

1962

(:method ((interval spocq:revision-interval))

1963

(let ((end (spocq:revision-interval-end interval)))

1964

(typecase end

1965

(null nil)

1966

(repository-revision (rlmdb:revision-record-date-time (repository-revision-record end)))

1967

(t (let ((record (rlmdb:find-revision-record *repository* end)))

1968

(when record (rlmdb:revision-record-date-time record))))))))

1969

1970

(defgeneric revision-interval-end-ordinal (interval)

1971

(:method ((object t))

1972

nil)

1973

(:method ((interval spocq:revision-interval))

1974

(let ((end (spocq:revision-interval-end interval)))

1975

(typecase end

1976

(null nil)

1977

(repository-revision (rlmdb:revision-record-ordinal (repository-revision-record end)))

1978

(t (let ((record (rlmdb:find-revision-record *repository* end)))

1979

(when record (rlmdb:revision-record-ordinal record))))))))

1980

1981

(defgeneric revision-interval-end-revision (interval)

1982

(:method ((object t))

1983

nil)

1984

(:method ((interval spocq:revision-interval))

1985

(let ((end (spocq:revision-interval-end interval)))

1986

(typecase end

1987

(null nil)

1988

(repository-revision end)

1989

(t (when *repository*

1990

(let ((revision-id (rlmdb:find-revision-uuid *repository* end)))

1991

(repository-revision revision-id :reference *repository*

1992

                                     :class (repository-revision-class *repository*)))))))))

1993

1994

(defgeneric revision-interval-end-revision-record (interval)

1995

(:method ((object t))

1996

nil)

1997

(:method ((interval spocq:revision-interval))

1998

(let ((end (spocq:revision-interval-end interval)))

1999

(typecase end

2000

(null nil)

2001

(repository-revision (repository-revision-record end))

2002

(t (rlmdb:find-revision-record *repository* end))))))

2003

2004

2005

(defgeneric revision-interval-start-date-time (interval)

2006

(:method ((object t))

2007

nil)

2008

(:method ((interval spocq:revision-interval))

2009

(let ((start (spocq:revision-interval-start interval)))

2010

(typecase start

2011

(null nil)

2012

(repository-revision (rlmdb:revision-record-date-time (repository-revision-record start)))

2013

(t (let ((record (rlmdb:find-revision-record *repository* start)))

2014

(when record (rlmdb:revision-record-date-time record))))))))

2015

2016

(defgeneric revision-interval-start-ordinal (interval)

2017

(:method ((object t))

2018

nil)

2019

(:method ((interval spocq:revision-interval))

2020

(let ((start (spocq:revision-interval-start interval)))

2021

(typecase start

2022

(null nil)

2023

(repository-revision (rlmdb:revision-record-ordinal (repository-revision-record start)))

2024

(t (let ((record (rlmdb:find-revision-record *repository* start)))

2025

(when record (rlmdb:revision-record-ordinal record))))))))

2026

2027

(defgeneric revision-interval-start-uuid (interval)

2028

(:method ((object t))

2029

nil)

2030

(:method ((interval spocq:revision-interval))

2031

(let ((start (spocq:revision-interval-start interval)))

2032

(typecase start

2033

(null nil)

2034

(repository-revision (rlmdb:revision-record-uuid (repository-revision-record start)))

2035

(t (let ((record (rlmdb:find-revision-record *repository* start)))

2036

(when record (rlmdb:revision-record-uuid record))))))))

2037

2038

(defgeneric revision-interval-start-revision (interval)

2039

(:method ((object t))

2040

nil)

2041

(:method ((interval spocq:revision-interval))

2042

(let ((start (spocq:revision-interval-start interval)))

2043

(typecase start

2044

(null nil)

2045

(repository-revision start)

2046

(t (when *repository*

2047

(let ((revision-id (rlmdb:find-revision-uuid *repository* start)))

2048

(repository-revision revision-id :reference *repository*

2049

                                     :class (repository-revision-class *repository*)))))))))

2050

2051

(defgeneric revision-interval-start-revision-record (interval)

2052

(:method ((object t))

2053

nil)

2054

(:method ((interval spocq:revision-interval))

2055

(let ((start (spocq:revision-interval-start interval)))

2056

(typecase start

2057

(null nil)

2058

(repository-revision (repository-revision-record start))

2059

(t (rlmdb:find-revision-record *repository* start))))))

2060

2061

;;;

2062

;;; time

2063

2064

(defun constrain-time-fragments (fraction second minute hour zone)

2065

(constrain-temporal-fragments (fraction second minute hour zone) |xsd|:|time|))

2066

2067

(defun normalize-time-fragments (fraction second minute hour)

2068

(normalize-location-fraction-second-to-minute fraction second minute)

2069

(normalize-location-minute-to-hour minute hour)

2070

(values fraction second minute hour))

2071

2072

(test:test spocq.temporal-data.normalize-time-fragments

2073

   (list (loop for second from 0 to 120 by 10 collect (list second (multiple-value-list (normalize-time-fragments 1 second 59 23))))

2074

         (loop for minute from 0 to 120 by 10 collect (list minute (multiple-value-list (normalize-time-fragments 1 2 minute 23))))

2075

         (loop for second from 0 downto -120 by 10 collect (list second (multiple-value-list (normalize-time-fragments 1 second 59 1))))

2076

         (loop for minute from 0 downto -120 by 10 collect (list minute (multiple-value-list (normalize-time-fragments 1 2 minute 1)))))

2077

'(((0 (1 0 59 23)) (10 (1 10 59 23)) (20 (1 20 59 23)) (30 (1 30 59 23))

2078

(40 (1 40 59 23)) (50 (1 50 59 23)) (60 (1 0 0 24)) (70 (1 10 0 24))

2079

(80 (1 20 0 24)) (90 (1 30 0 24)) (100 (1 40 0 24)) (110 (1 50 0 24))

2080

(120 (1 0 1 24)))

2081

((0 (1 2 0 23)) (10 (1 2 10 23)) (20 (1 2 20 23)) (30 (1 2 30 23))

2082

(40 (1 2 40 23)) (50 (1 2 50 23)) (60 (1 2 0 24)) (70 (1 2 10 24))

2083

(80 (1 2 20 24)) (90 (1 2 30 24)) (100 (1 2 40 24)) (110 (1 2 50 24))

2084

(120 (1 2 0 25)))

2085

((0 (1 0 59 1)) (-10 (1 50 58 1)) (-20 (1 40 58 1)) (-30 (1 30 58 1))

2086

(-40 (1 20 58 1)) (-50 (1 10 58 1)) (-60 (1 0 58 1)) (-70 (1 50 57 1))

2087

(-80 (1 40 57 1)) (-90 (1 30 57 1)) (-100 (1 20 57 1)) (-110 (1 10 57 1))

2088

(-120 (1 0 57 1)))

2089

((0 (1 2 0 1)) (-10 (1 2 50 0)) (-20 (1 2 40 0)) (-30 (1 2 30 0))

2090

(-40 (1 2 20 0)) (-50 (1 2 10 0)) (-60 (1 2 0 0)) (-70 (1 2 50 -1))

2091

(-80 (1 2 40 -1)) (-90 (1 2 30 -1)) (-100 (1 2 20 -1)) (-110 (1 2 10 -1))

2092

(-120 (1 2 0 -1)))))

2093

2094

(defun make-time (fraction second minute hour &optional (zone 0))

2095

"Given fraction second minute hour fragments, make a time.

2096

Normalize fragments as required."

2097

   (encode-time fraction second minute hour spocq:+reference-day+ spocq:+reference-month+ spocq:+reference-year+ zone))

2098

2099

2100

(defun encode-time (fraction second minute hour day month year &optional (zone spocq:+reference-zone+))

2101

   "Given all temporal fragments, construct a time with the specified zoned fragments normalized to utc.

2102

  The fragment value are canonicalized to zulu time in order facilitate comparisons, but the zone is retained.

2103

(see http://www.w3.org/TR/xpath-functions-30/#func-time-equal)"

2104

(multiple-value-setq (fraction second minute hour)

2105

(normalize-time-fragments fraction second minute hour))

2106

(when (offset-zone-p zone)

2107

(multiple-value-setq (fraction second minute hour day month year)

2108

       (canonicalize-date-time-fragments fraction second minute hour day month year zone spocq:+reference-zone+)))

2109

(spocq:make-time :fraction fraction :second second :minute minute :hour hour

2110

:day day :month month :year year :zone zone))

2111

2112

2113

(defun parse-|HH:mm:ss(ZZZZ)?| (string)

2114

(handler-case

2115

(multiple-value-bind (match substrings)

2116

                          (cl-ppcre:scan-to-strings (load-time-value (cl-ppcre:create-scanner "^([0-9][0-9]):([0-9][0-9]):([0-9][0-9])(?:\\.([0-9]+))?(([zZ])|([+-])([0-9][0-9]):([0-9][0-9]))?$"))

2117

string)

2118

(assert match () "invalid time lexical form")

2119

(let* ((hour (parse-integer (aref substrings 0)))

2120

(minute (parse-integer (aref substrings 1)))

2121

(second (parse-integer (aref substrings 2)))

2122

(fraction (let* ((string (aref substrings 3))

2123

(integer (if string (parse-integer string) 0)))

2124

(if (zerop integer) 0

2125

(/ (* +timeline-units-per-second+ integer)

2126

                                 (aref #(1 10 100 1000 10000 100000 1000000) (min (length string) 6)))))))

2127

(if (aref substrings 4)

2128

(if (aref substrings 5)

2129

(values fraction second minute hour 0)

2130

(let* ((zone-sign (aref substrings 6))

2131

(zone-hours (aref substrings 7))

2132

(zone-minutes (aref substrings 8)))

2133

(values fraction second minute hour

2134

(* (if (equal zone-sign "-") -1 1)

2135

(+ (parse-integer zone-hours)

2136

(/ (parse-integer zone-minutes) 60))))))

2137

(values fraction second minute hour nil))))

2138

(error ()

2139

(invalid-argument-type |xsd|:|time| string |xsd|:|time|))))

2140

2141

2142

(defmethod temporal-decoded-p ((term spocq:time))

2143

(not (null (spocq:time-hour term))))

2144

2145

(defgeneric decode-time (value)

2146

   (:documentation "GIven a time instance or a timeline or string designator, return the respective fragments.

2147

If the instance itself has not yet been initialized, do so from the avaialble designator")

2148

2149

(:method ((value spocq:time))

2150

"If the fragments are current, return them, otherwise deconstruct or parse as available."

2151

(let ((hour (spocq:time-hour value)))

2152

(if hour

2153

(values (spocq:time-fraction value)

2154

(spocq:time-second value)

2155

(spocq:time-minute value)

2156

hour

2157

;; non-time values may not have been set

2158

(or (spocq:time-day value) +timeline-universal-time-epoch-day+)

2159

(or (spocq:time-month value) +timeline-universal-time-epoch-month+)

2160

(or (spocq:time-year value) +timeline-universal-time-epoch-year+))

2161

(flet ((update-fragments (fraction second minute hour day month year zone)

2162

;; nb.!!! the lexical form can end up out-of-sync with the fragments

2163

(values (setf (spocq:time-fraction value) fraction)

2164

(setf (spocq:time-second value) second)

2165

(setf (spocq:time-minute value) minute)

2166

(setf (spocq:time-hour value) hour)

2167

(setf (spocq:time-day value) day)

2168

(setf (spocq:time-month value) month)

2169

(setf (spocq:time-year value) year)

2170

(setf (spocq:time-zone value) zone))))

2171

(let ((location (spocq:temporal-timeline-location value)))

2172

(if location

2173

(multiple-value-call #'update-fragments (decode-time location))

2174

(let ((lexical-form (spocq:literal-lexical-form value)))

2175

(if lexical-form

2176

(multiple-value-call #'update-fragments (decode-time lexical-form))

2177

(error "Invalid time: ~s" value)))))))))

2178

2179

(:method ((location integer))

2180

"Given a location, parse it and return the fragments. Pin the zone."

2181

(multiple-value-bind (fraction second minute hour day month year)

2182

(dydra-ndk::decode-time location spocq:+reference-zone+)

2183

(values fraction second minute hour day month year 0)))

2184

2185

(:method ((lexical-form string))

2186

"Given a lexical form string, parse it, constrain, then canonicalize, then return.

2187

No normalization happens, as the lexical contraints proscribe such values."

2188

(multiple-value-bind (fraction second minute hour zone)

2189

                          (multiple-value-call #'constrain-time-fragments (parse-|HH:mm:ss(ZZZZ)?| lexical-form))

2190

(when (= 24 hour)

2191

(setf hour 0))

2192

(unless zone (setf zone spocq:+reference-zone+))

2193

;; establish the reference day month year in order to persist shift results

2194

(let ((day spocq:+reference-day+)

2195

(month spocq:+reference-month+)

2196

(year spocq:+reference-year+))

2197

(multiple-value-setq (fraction second minute hour day month year)

2198

(canonicalize-date-time-fragments fraction second minute hour day month year zone 0))

2199

(values fraction second minute hour day month year zone)))))

2200

 (declaim (ftype (function ((or spocq:time string integer)) (values fixnum fixnum fixnum fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) decode-time))

2201

2202

2203

 (defmethod spocq:format-time (stream (object spocq:time) &optional expand-zulu-p offset-zone-p (zone (time-zone object)))

2204

;; always format

2205

(multiple-value-bind (fraction second minute hour day month year) (decode-time object)

2206

(when (and offset-zone-p (offset-zone-p zone))

2207

(multiple-value-setq (fraction second minute hour day month year)

2208

(canonicalize-date-time-fragments 0 0 0 day month year 0 zone)))

2209

(format stream "~2,'0d:~2,'0d:~2,'0d~@[~a~]"

2210

hour minute second

2211

(unless (zerop fraction)

2212

(let* ((float (float (/ (abs fraction) +timeline-units-per-second+)))

2213

(string (format nil "~f" float)))

2214

(subseq string 1))))

2215

(spocq:format-zone-offset stream zone expand-zulu-p nil)))

2216

2217

(defgeneric |HH:mm:ss(ZZZZ)?| (object)

2218

(:method ((object string))

2219

(multiple-value-bind (fraction second minute hour day month year zone)

2220

(decode-time object)

2221

(declare (ignore day month year))

2222

(spocq:make-time :fraction fraction :second second :minute minute :hour hour

2223

:zone zone :lexical-form object)))

2224

(:method ((object spocq:time))

2225

;; double check for an extant lexical form

2226

(or (spocq:literal-lexical-form object)

2227

(setf (spocq:literal-lexical-form object)

2228

(with-output-to-string (stream) (spocq:format-time stream object nil t))))))

2229

2230

#+(or)

2231

(date::define-date-conversion-function "HH:mm:ssZZZZ"

2232

:type spocq:time :package :spocq.i

2233

:time-encoder (lambda (sec min hr day month year zone)

2234

                   (encode-time 0 sec min hr day month year zone)) :time-decoder decode-time)

2235

2236

#+(or)

2237

(date::define-date-conversion-function "HH:mm:ss"

2238

:type spocq:time :package :spocq.i

2239

:time-encoder (lambda (sec min hr day month year)

2240

(encode-time 0 sec min hr day month year 0)) :time-decoder decode-time)

2241

2242

(defun universal-time-time (time)

2243

(multiple-value-bind (sec min hour day month year)

2244

(decode-universal-time time 0)

2245

(declare (ignore sec))

2246

(spocq:make-time :fraction 0 :minute min :hour hour :day day :month month :year year

2247

:zone 0)))

2248

2249

(defun timeline-location-time (value)

2250

(spocq:make-time :timeline-location value :zone 0))

2251

2252

(defun time-timeline-location (time)

2253

"Given a time, return the cached temporal value or compute it from the components."

2254

(or (spocq:temporal-timeline-location time)

2255

(setf (spocq:temporal-timeline-location time)

2256

(multiple-value-bind (fraction second minute hour day month year)

2257

(decode-time time)

2258

;; drop the zone

2259

               (dydra-ndk::encode-time fraction second minute hour day month year spocq:+reference-zone+)))))

2260

2261

2262

(defun time-second-location (time)

2263

"Given a time, return the cached location value or compute it from the components."

2264

(let ((location (time-timeline-location time)))

2265

(nth-value 1 (truncate location +timeline-units-per-day+))))

2266

2267

2268

;;;

2269

;;; year-month-duration

2270

2271

(defun constrain-year-month-duration-fragments (month year)

2272

(constrain-temporal-fragments (month year) |xsd|:|yearMonthDuration|))

2273

2274

(defun normalize-year-month-duration-fragments (month year)

2275

(normalize-duration-month-to-year month year)

2276

(values month year))

2277

2278

(test:test spocq.temporal-data.normalize-year-month-duration-fragments

2279

(loop for i from -13 to 13 collect

2280

(let ((month i) (year 1900))

2281

(list i (multiple-value-list (normalize-year-month-duration-fragments month year)))))

2282

'((-13 (-1 1899)) (-12 (0 1899)) (-11 (-11 1900)) (-10 (-10 1900))

2283

(-9 (-9 1900)) (-8 (-8 1900)) (-7 (-7 1900)) (-6 (-6 1900)) (-5 (-5 1900))

2284

(-4 (-4 1900)) (-3 (-3 1900)) (-2 (-2 1900)) (-1 (-1 1900)) (0 (0 1900))

2285

(1 (1 1900)) (2 (2 1900)) (3 (3 1900)) (4 (4 1900)) (5 (5 1900)) (6 (6 1900))

2286

(7 (7 1900)) (8 (8 1900)) (9 (9 1900)) (10 (10 1900)) (11 (11 1900))

2287

(12 (0 1901)) (13 (1 1901))))

2288

2289

;;; no canonicalization, as no zone is present

2290

2291

(defun make-year-month-duration (month year)

2292

"Given a month and a year, make a year-month-duration from fragments."

2293

(multiple-value-setq (month year)

2294

(normalize-year-month-duration-fragments month year))

2295

(spocq:make-year-month-duration :month month :year year))

2296

2297

(defun encode-year-month-duration (fraction second minute hour day month year &optional (zone 0))

2298

"Given temporal fragments, construct a year-month-duration with the specified zone.

2299

Seconds through days are, if any, are ignored, as they do not apply.

2300

Hours are also ignored as they are reflect by the zone only.

2301

Constrain fragments according to the respective lexical constraints.

2302

Handle the year so as to allow negative values."

2303

(declare (ignore fraction second minute hour day zone))

2304

(make-year-month-duration month year))

2305

2306

2307

(defun parse-|PnYnM| (string &optional (error-p t))

2308

(handler-case

2309

(multiple-value-bind (match substrings)

2310

                          (cl-ppcre:scan-to-strings (load-time-value (cl-ppcre:create-scanner "^(-)?P(?:([0-9]+)Y)?(?:([0-9]+)M)?$"))

2311

string)

2312

(cond (match

2313

(let ((sign (if (equal (aref substrings 0) "-") -1 +1)))

2314

(flet ((field-integer (string) (if string (* sign (parse-integer string)) 0)))

2315

(values (field-integer (aref substrings 2))

2316

(field-integer (aref substrings 1))))))

2317

(error-p

2318

(assert match () "invalid gYearMonth lexical form"))))

2319

(error ()

2320

              (invalid-argument-type |xsd|:|yearMonthDuration| string |xsd|:|yearMonthDuration|))))

2321

2322

2323

(defmethod temporal-decoded-p ((term spocq:year-month-duration))

2324

(not (null (spocq:year-month-duration-month term))))

2325

2326

(defgeneric decode-year-month-duration (value)

2327

   (:documentation "GIven a year-month-duration return all temporal fragments, whereby only the year and month signify

2328

and the remainder are clamped to zero.

2329

zone is ignored")

2330

2331

(:method ((value spocq:year-month-duration))

2332

(let ((month (spocq:year-month-duration-month value)))

2333

       (if month                         ; extract sub-month values even though no operator creates them

2334

(values (spocq:year-month-duration-fraction value)

2335

(spocq:year-month-duration-second value)

2336

(spocq:year-month-duration-minute value)

2337

(spocq:year-month-duration-hour value)

2338

(spocq:year-month-duration-day value)

2339

month

2340

(spocq:year-month-duration-year value)

2341

spocq:+reference-zone+)

2342

(flet ((update-fragments (fraction second minute hour day month year zone)

2343

;; nb.!!! the lexical form can end up out-of-sync with the fragments

2344

(values (setf (spocq:year-month-duration-fraction value) fraction)

2345

(setf (spocq:year-month-duration-second value) second)

2346

(setf (spocq:year-month-duration-minute value) minute)

2347

(setf (spocq:year-month-duration-hour value) hour)

2348

(setf (spocq:year-month-duration-day value) day)

2349

(setf (spocq:year-month-duration-month value) month)

2350

(setf (spocq:year-month-duration-year value) year)

2351

zone)))

2352

(let ((month-location (spocq:year-month-duration-month-location value)))

2353

(if month-location

2354

(multiple-value-call #'update-fragments (decode-year-month-duration month-location))

2355

(let ((lexical-form (spocq:literal-lexical-form value)))

2356

(if lexical-form

2357

                   (multiple-value-call #'update-fragments (decode-year-month-duration lexical-form))

2358

(error "Invalid year-month-duration: ~s" value)))))))))

2359

2360

(:method ((month-location integer))

2361

(multiple-value-bind (year month) (truncate month-location +timeline-months-per-year+)

2362

(values 0 0 0 0 0 month year 0)))

2363

2364

(:method ((lexical-form string))

2365

"Given a lexical form string, parse it, constrain, then canonicalize, then return.

2366

Normalize the values."

2367

(multiple-value-bind (month year)

2368

(multiple-value-call #'normalize-year-month-duration-fragments

2369

                                               (parse-|PnYnM| lexical-form))

2370

(values 0 0 0 0 0 month year 0))))

2371

 (declaim (ftype (function ((or spocq:year-month-duration string integer)) (values fixnum fixnum fixnum fixnum fixnum fixnum fixnum (or null spocq:zone-fragment))) decode-year-month-duration))

2372

2373

2374

(defmethod spocq:format-year-month-duration (stream (object spocq:year-month-duration) &optional colon at)

2375

(declare (ignore colon at))

2376

(let* ((year (year-month-duration-year object)) ; the first access so, to ensure decoding

2377

(month (spocq:year-month-duration-month object))

2378

(zero-duration (and (zerop year) (zerop month))))

2379

(cond (zero-duration

2380

(write-string "P0M" stream))

2381

(t

2382

(format stream "~:[~;-~]P~@[~dY~]~@[~dM~]"

2383

(or (minusp year) (minusp month))

2384

(unless (zerop year) (abs year))

2385

(unless (zerop month) (abs month)))))))

2386

2387

(defgeneric |PnYnM| (object)

2388

(:documentation

2389

"Convert between lexical form and value for a year-month duration.

2390

This permits just the year and month fragments and also no zone.")

2391

2392

(:method ((object string))

2393

(let ((result (multiple-value-call #'make-year-month-duration (parse-|PnYnM| object))))

2394

(setf (spocq:literal-lexical-form result) object)

2395

result))

2396

2397

(:method ((object spocq:year-month-duration))

2398

(or (spocq:literal-lexical-form object)

2399

(setf (spocq:literal-lexical-form object)

2400

(with-output-to-string (stream) (spocq:format-year-month-duration stream object))))))

2401

2402

;;; (loop for form in '("P0Y" "P2014Y3M" "-P2014Y3M") do (assert (equal form (|PnYnM| (|PnYnM| form)))))

2403

2404

2405

(defun universal-time-year-month-duration (value)

2406

(multiple-value-bind (second minute hour day month year) (decode-universal-time value 0)

2407

(declare (ignore second minute hour day))

2408

(spocq:make-year-month-duration :month month :year year)))

2409

2410

(defun timeline-location-year-month-duration (value)

2411

   (multiple-value-bind (fraction second minute hour day month year) (dydra-ndk:decode-time value spocq:+reference-zone+)

2412

(declare (ignore fraction second minute hour day))

2413

(spocq:make-year-month-duration :month month :year year)))

2414

2415

(defmethod duration-month-location ((temporal spocq:year-month-duration))

2416

(year-month-duration-month-location temporal))

2417

2418

(defun year-month-duration-month-location (value)

2419

"Given a year-month-duration, return the cached location value or compute it from the components."

2420

(or (spocq:year-month-duration-month-location value)

2421

(setf (spocq:year-month-duration-month-location value)

2422

(nth-value 0 (compute-duration-locations 0 0 0 0 0

2423

                                                      (spocq:year-month-duration-month value)

2424

                                                      (spocq:year-month-duration-year value))))))

2425

2426

(defmethod duration-second-location ((temporal spocq:year-month-duration))

2427

0)

2428

2429

2430

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

2431

2432

(defgeneric temporal-timeline-location (temporal)

2433

(:method ((temporal spocq:date))

2434

(date-timeline-location temporal))

2435

2436

(:method ((temporal spocq:date-time))

2437

(date-time-timeline-location temporal))

2438

2439

(:method ((temporal spocq:day-time-duration))

2440

(day-time-duration-second-location temporal))

2441

2442

(:method ((temporal spocq:duration))

2443

(duration-timeline-location temporal))

2444

2445

(:method ((temporal spocq:time))

2446

(time-timeline-location temporal))

2447

2448

(:method ((temporal spocq:year-month-duration))

2449

(year-month-duration-month-location temporal)))

2450

2451

2452

#|

2453

2454

#+(or)

2455

(date::define-date-conversion-function "-yyyy-MM-ddZZZZ"

2456

:type spocq:date :package :spocq.i

2457

:time-encoder (lambda (sec min hr day month year zone)

2458

(encode-date 0 sec min hr day month year zone))

2459

:time-decoder decode-date)

2460

#+(or)

2461

(date::define-date-conversion-function "-yyyy-MM-dd"

2462

:type spocq:date :package :spocq.i

2463

:time-encoder (lambda (sec min hr day month year)

2464

(encode-date 0 sec min hr day month year 0))

2465

:time-decoder decode-date)

2466

2467

2468

#+(or)

2469

(date::define-date-conversion-function "-yyyy-MM-ddTHH:mm:ssZZZZ"

2470

:type spocq:date-time :package :spocq.i

2471

:time-encoder (lambda (sec min hr day month year zone)

2472

(encode-date-time 0 sec min hr day month year zone))

2473

:time-decoder (lambda (date-time zone)

2474

(decode-temporal date-time zone)))

2475

2476

#+(or)

2477

(date::define-date-conversion-function "yyyy-MM-ddTHH:mm:ssZZZZ"

2478

:type spocq:date-time :package :spocq.i

2479

:time-encoder (lambda (sec min hr day month year zone)

2480

(encode-date-time 0 sec min hr day month year zone))

2481

:time-decoder (lambda (date-time zone)

2482

(decode-temporal date-time zone)))

2483

2484

#+(or)

2485

(date::define-date-conversion-function "-yyyy-MM-ddTHH:mm:ss"

2486

:type spocq:date-time :package :spocq.i

2487

:time-encoder (lambda (sec min hr day month year)

2488

(encode-date-time 0 sec min hr day month year 0))

2489

:time-decoder decode-date-time)

2490

2491

2492

2493

|#