1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
;;; -*- Mode: Lisp -*-
;;; $Id: duration.lisp,v 1.13 2002/01/11 22:00:04 jesse Exp $
;;;
;;; Copyright (c) 2000, 2001 onShore Development, Inc.
;;;
;;; durations
(in-package :local-time)
(defun make-duration (&key (day 0) (hour 0) (sec 0) (msec 0))
"Make a duration instance"
(multiple-value-bind (msec-seconds msecs)
(truncate msec 1000)
(multiple-value-bind (hour-days hours)
(truncate hour 24)
(multiple-value-bind (sec-days seconds)
(truncate (+ msec-seconds sec (* hours 60 60)) +seconds/day+)
(%make-duration :day (+ day sec-days hour-days)
:sec seconds
:msec msecs)))))
(defun duration-designator (designator)
"convert a designator (real number) into a local-time instance"
(make-duration :msec designator))
(defun duration-minutes (duration)
(let* ((seconds (duration-sec duration))
(days (duration-day duration))
(minutes (truncate seconds 60)))
(multiple-value-bind (hh mm) (truncate minutes 60)
(+ (* 60 (+ hh (* 24 days))) mm))))
(defun designate-duration (duration)
"returns the number of milliseconds in DURATION"
(if duration
(+ (* (duration-day duration) +msecs/day+)
(* (duration-sec duration) 1000)
(duration-msec duration))
0))
(defun day-duration (duration)
(multiple-value-bind (ms ss mm hh)
(decode-duration duration)
(= 0 ms ss mm hh)))
(defun duration< (&rest durations)
(apply #'< (mapcar #'designate-duration durations)))
(defun duration<= (&rest durations)
(apply #'<= (mapcar #'designate-duration durations)))
(defun duration> (&rest durations)
(apply #'> (mapcar #'designate-duration durations)))
(defun duration>= (&rest durations)
(apply #'>= (mapcar #'designate-duration durations)))
(defun duration= (&rest durations)
(apply #'= (mapcar #'designate-duration durations)))
(defun duration/= (&rest durations)
(apply #'/= (mapcar #'designate-duration durations)))
(defun duration+ (&rest durations)
"Add DURATIONS"
(duration-designator (apply #'+ (mapcar #'designate-duration durations))))
(defun duration- (&rest durations)
"Add DURATIONS"
(duration-designator (apply #'- (mapcar #'designate-duration durations))))
(defun duration* (&rest durations)
"Multiply DURATIONS"
(duration-designator (apply #'* (mapcar #'designate-duration durations))))
(defun duration/ (duration1 duration2)
"Divide DURATIONS. returns a number, not a duration"
(/ (designate-duration duration1)
(designate-duration duration2)))
(defun duration-hours (duration)
"return the local-time as a number of hours, rounded down"
(let* ((day-hours (* 24 (duration-day duration))))
(+ day-hours
(floor (/ (duration-sec duration) +seconds/hour+)))))
(defun duration-seconds (duration)
"return the local-time as a number of seconds"
(/ (designate-duration duration) 1000))
(defun %duration-prec (prec)
(let ((prec (position prec '(:milliseconds :seconds :minutes :hours :days))))
(if prec
(1- prec)
0)))
(defun duration-to-string (dur &key precision)
(let ((prec (%duration-prec precision)))
(flet ((part (quantity name)
(unless (= quantity 0)
(format nil "~d ~a~p" quantity name quantity))))
(let* ((components (multiple-value-list (decode-duration-print dur)))
(names '("week" "day" "hour" "minute" "second" "millisecond"))
(strings (remove-if #'null (mapcar #'part components names))))
(format nil "~{~a~^ ~}" (reverse (nthcdr prec (reverse strings))))))))
(defun decode-duration-print (duration)
"returns the decoded duration as multiple values: weeks days hours minutes
seconds milliseconds"
(multiple-value-bind (ms ss mm hh dd)
(decode-duration duration)
(multiple-value-bind (weeks days)
(floor dd 7)
(values weeks days hh mm ss ms))))
(defun decode-duration (duration)
"returns the decoded duration as multiple values: ms, ss, mm, hh, days"
(let ((seconds (duration-sec duration))
(days (duration-day duration))
(ms (duration-msec duration)))
(multiple-value-bind (minutes ss)
(truncate seconds +seconds/minute+)
(multiple-value-bind (hh mm)
(truncate minutes +minutes/hour+)
(values (or ms 0) ss mm hh days)))))
|