blob: 9a703a3a66e0a6637c13e3fe5b1662af269fef8b (
plain)
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
|
;;;; fuzzytime.lisp
(IN-PACKAGE #:FUZZYTIME)
(EXPORT '(*FUZZYTIME-FORMAT* *MINUTE-GRANULARITY*))
(PUSHNEW '(#\F LOCAL-TIME-TO-FUZZY) *SCREEN-MODE-LINE-FORMATTERS* :TEST 'EQUAL)
(DEFPARAMETER *MINUTE-GRANULARITY* 10
"Minutes are rounded to the nearest multiple of *minute-granularity*")
(DEFPARAMETER *FUZZYTIME-FORMAT*
'(:MINUTES :HOURS " in the " :PERIOD " on " :DOW
" the " :DAY " of " :MONTH)
"Format of the output, a list of strings and keywords. Valid keywords are:
:minutes
:hours
:period
:dow (name of the day of the week)
:udow (name of the day of the week, capitalised)
:dn (number of the day of the week)
:day (day of the month)
:mnum (number of the month)
:month (name of the month, capitalised)
:umonth (name of the month)")
(DEFVAR *MONTH-NAMES*
(MAKE-ARRAY '(12) :INITIAL-CONTENTS
'("january" "february" "march" "april" "may" "june" "july"
"august" "september" "october" "november" "december")))
(DEFVAR *DOW-NAMES*
(MAKE-ARRAY '(7) :INITIAL-CONTENTS
'("monday" "tuesday" "wednesday"
"thursday" "friday" "saturday"
"sunday")))
(DEFUN MINUTES-TO-WORDS (MIN)
(IF (OR (<= MIN 0) (>= MIN 60)) ""
(FLET ((FRAC (M) (COND
((= M 30) "half")
((= M 15) "quarter")
(T (FORMAT NIL "~r" M)))))
(FORMAT NIL "~a ~a " (FRAC (IF (> MIN 30) (- 60 MIN) MIN))
(IF (> MIN 30) "to" "past")))))
(DEFUN HOUR-TO-WORDS (HOUR MIN)
(LET ((H (MOD
(IF (> MIN 30) (1+ HOUR) HOUR )
12)))
(FORMAT NIL "~r~a"
(IF (= H 0) 12 H)
(IF (OR (= MIN 0) (= MIN 60)) " o'clock" ""))))
(DEFUN PERIOD-INDICATOR (HOUR)
(IF (< HOUR 12) "morning"
(IF (< HOUR 17) "afternoon" "evening")))
(DEFUN LOCAL-TIME-TO-FUZZY (ML)
(DECLARE (IGNORE ML))
(MULTIPLE-VALUE-BIND (SECONDS MINUTES HOUR DAY MONTH YEAR DOW)
(GET-DECODED-TIME)
(DECLARE (IGNORE SECONDS) (IGNORE YEAR))
(LET* ((MIN (* *MINUTE-GRANULARITY*
(ROUND (/ MINUTES *MINUTE-GRANULARITY*))))
(MS (MINUTES-TO-WORDS MIN))
(HS (HOUR-TO-WORDS HOUR MIN))
(PS (PERIOD-INDICATOR HOUR))
(DN (ELT *DOW-NAMES* DOW))
(MN (ELT *MONTH-NAMES* (1- MONTH))))
(APPLY #'CONCATENATE 'STRING
(LOOP FOR E IN *FUZZYTIME-FORMAT* COLLECT
(CASE E
(:MINUTES MS)
(:HOURS HS)
(:PERIOD PS)
(:DOW DN)
(:UDOW (STRING-CAPITALIZE DN))
(:MONTH MN)
(:UMONTH (STRING-CAPITALIZE MN))
(:DNUM (FORMAT NIL "~a" DOW))
(:DAY (FORMAT NIL "~:r" DAY))
(:MNUM (FORMAT NIL "~a" MONTH))
(OTHERWISE E)))))))
|
