#!/usr/local/bin/clisp -ansi -q -E utf-8
;;;; -*- mode:lisp; coding:utf-8 -*-
;;----------------------------------------------------------------------
(defun optionp (options key)
(if (atom options)
(string= options key)
(member key options :test (function string=))))
(defun opts (name)
(list (format nil "-~A" (char (string name) 0))
(format nil "--~(~A~)" name)
(format nil "~(~A~)" name)))
;;----------------------------------------------------------------------
(defconstant +day+ (* 24 60 60))
(defun ut-from-date (yyyy-mm-dd)
(multiple-value-bind (y p)
(parse-integer yyyy-mm-dd :junk-allowed t :start 0)
(multiple-value-bind (m p)
(parse-integer yyyy-mm-dd :junk-allowed t :start (1+ p))
(multiple-value-bind (d p)
(parse-integer yyyy-mm-dd :junk-allowed nil :start (1+ p))
(encode-universal-time 0 0 0 d m y)))))
(defun date-label (ut)
(multiple-value-bind (se mi ho da mo ye) (decode-universal-time ut)
(format nil "~4,'0D-~2,'0D-~2,'0D" ye mo da)))
(defun days-from-duration (n units)
(* n
(cond
((optionp '("day" "days") units) 1)
((optionp '("week" "weeks") units) 7)
((optionp '("month" "months") units) 30)
((optionp '("year" "years") units) 365)
(t (error "Invalid time unit: ~S" units)))))
(defun duration-label (days)
(cond
((zerop (mod days 365)) (format nil "~4D year~:*~P" (truncate days 365)))
((zerop (mod days 30)) (format nil "~4D month~:*~P" (truncate days 30)))
((zerop (mod days 7)) (format nil "~4D week~:*~P" (truncate days 7)))
(t (format nil "~4D day~:*~P" days))))
(defun test-durations ()
(dolist (test
(mapcan (lambda (n) (mapcar (lambda (u) (list n u))
'("day" "days" "week" "weeks" "month" "months"
"year" "years" "furlong")))
'(0 1 6 7 8 13 14 15 29 30 31 59 60 61 364 365 366
729 730 731)))
(let* ((r1 (ignore-errors
(days-from-duration (first test) (Second test))))
(r2 (when r1 (duration-label r1))))
(print `(,test ,r1 ,r2)))))
;;----------------------------------------------------------------------
(defparameter *memo-dir* (merge-pathnames ".memo/" (user-homedir-pathname))
"Where the memos are stored.")
(defun print-usage ()
(format t
"~&usage:~
~%~:{~% memo ~{~A~^|~} ~A~}~
~%~
~% date: YYYY-MM-DD or now~
~% duration: N (day|week|month|year)[s]~
~2%"
`((,(opts "help") "")
(,(opts "list") "")
(,(opts "show") "")
(,(opts "add") "[from $date [for $duration]] $text $of $the $memo.")
(,(opts "remove") "$memonum")
(,(opts "purge") ""))))
;;memo add from now do something
;;memo add from 2006-03-15 aniversaire
;;memo add from 2006-03-15 for 1 (day|week|month|year)[s] aniversaire
(defstruct (memo (:type list))
pathname
date
duration
lines)
(defun memo-path (num)
(make-pathname :name num :type "MEMO" :case :common :defaults *memo-dir*))
(defun memo-files ()
(directory (memo-path :wild)))
(defun memo-new-path ()
(loop
:for num :from 0 :to 999
:do (let ((path (memo-path (format nil "~3,'0D" num))))
(unless (probe-file path)
(return-from memo-new-path path))))
(error "Too many memos. Purge or remove some."))
(defun load-memos ()
(mapcar (lambda (file)
(with-open-file (memo file)
(make-memo :pathname file
:date (read memo)
:duration (read memo)
:lines (loop :for line = (read-line memo nil nil)
:while line :collect line))))
(memo-files)))
(defun save-memo (memo)
(with-open-file (file (memo-pathname memo)
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(format file "~S ~S~%" (memo-date memo) (memo-duration memo))
(format file "~&~{~A~%~}" (memo-lines memo))))
(defun list-memos ()
(dolist (memo (sort (load-memos) (function string<=)
:key (lambda (memo) (namestring (memo-pathname memo)))))
(format t "~3:A~:[~; from ~:*~10A~]~:[~; for ~:*~10A~]~
~2:*~:[~;~% ~]~* ~A~:[~;...~]~%"
(pathname-name (memo-pathname memo))
(when (memo-date memo) (date-label (ut-from-date (memo-date memo))))
(when (memo-duration memo) (duration-label (memo-duration memo)))
(first (memo-lines memo))
(rest (memo-lines memo)))))
(defun show-memos ()
(dolist (memo (sort
(let ((today (get-universal-time)))
(remove-if
(lambda (memo)
(and (memo-date memo)
(or (< today (ut-from-date (memo-date memo)))
(and (memo-duration memo)
(< (+ (ut-from-date (memo-date memo))
(* +day+ (memo-duration memo)))
today)))))
(load-memos)))
(function string<=)
:key (lambda (memo) (namestring (memo-pathname memo)))))
(format t "~3:A ~{~A~^~% ~}~%"
(pathname-name (memo-pathname memo))
(memo-lines memo))))
(defun purge-memos ()
(mapc (lambda (memo) (delete-file (memo-pathname memo)))
(let ((today (get-universal-time)))
(remove-if
(lambda (memo)
(not (and (memo-date memo)
(memo-duration memo)
(< (+ (ut-from-date (memo-date memo))
(* +day+ (memo-duration memo)))
today))))
(load-memos)))))
(defun remove-memo (num)
(let ((num (handler-case (parse-integer num :junk-allowed nil)
(error (err) (error "Invalid memo number ~S" num)))))
(delete-file (memo-path (format nil "~3,'0D" num)))))
(defun add-memo (text)
(let (date duration)
(when (optionp "from" (first text))
(pop text)
(setf date (pop text))
(ut-from-date date)
(when (optionp "for" (first text))
(pop text)
(setf duration (days-from-duration (parse-integer (pop text)
:junk-allowed nil)
(pop text)))))
(let ((text (format nil "~{~A~^ ~}" text))
(path (memo-new-path)))
(save-memo (make-memo :pathname path
:date date
:duration duration
:lines (list text))))))
(defun main (argv)
(format t "~&")
(ensure-directories-exist (make-pathname :name "TEST" :defaults *memo-dir*))
(let ((key (first argv)))
(handler-case
(COND
((or (null argv) (optionp (opts "help") key)) (print-usage))
((optionp (opts "list") key) (list-memos))
((optionp (opts "show") key) (show-memos))
((optionp (opts "add") key) (add-memo (rest argv)))
((optionp (opts "remove") key) (remove-memo (second argv)))
((optionp (opts "purge") key) (purge-memos))
(t (format *error-output* "Invalid option: ~S~%" key)
(print-usage)))
(error (err)
(format *error-output* "~&~A~%" err)))))
(main ext:*args*)