Am 11.08.13 19:18, schrieb David McClain: > It is becoming more frequently the case that having a little Calendar > widget available to the user in GUI's would be vary convenient to have. > Has anyone seen one of those for Lisp? > > Dr. David McClain > dbm@refined-audiometrics.com <mailto:dbm@refined-audiometrics.com> > > > http://www.weitz.de/midgets/ jens _______________________________________________ Lisp Hug - the mailing list for LispWorks users lisp-hug@lispworks.com http://www.lispworks.com/support/lisp-hug.html
Unable to parse email body. Email id is 12384
Hi Madhu,
I can't compile this code because of :
(user:date :utime utime :stream nil :tz (tz tz-pane))
Do you know how to define this date function?
Best,
Camille
On 12 août 2013, at 04:39, Madhu <enometh@meer.net> wrote:
>
>
> * Jens Teich <5207C96E.4010608@jensteich.de> Wrote on Sun, 11 Aug 2013 19:27:10 +0200:
> | Am 11.08.13 19:18, schrieb David McClain:
> |
> |> It is becoming more frequently the case that having a little Calendar
> |> widget available to the user in GUI's would be vary convenient to have.
> |> Has anyone seen one of those for Lisp?
> |
> | http://www.weitz.de/midgets/
>
> A few years ago, when I was getting started with CAPI I needed to
> extend this widget, and ended up rewriting it, I'm appending that
> code, (now placed in Public Domain) in case it is useful for your
> further tinkering. --- Madhu
>
>
> ;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
> ;;;
> ;;; Time-stamp: <2009-10-11 18:41:33 IST>
> ;;; Touched: Tue Jun 02 21:47:14 2009 +0530 <enometh@meer.net>
> ;;; Bugs-To: enometh@meer.net
> ;;; Status: Experimental. Do not redistribute
> ;;; Copyright (C) 2009 Madhu. All Rights Reserved.
> ;;;
> (defpackage "DATE-TIME-CAPI"
> (:use "CL")
> (:export
> "DATE-INTERFACE"
> "DATE-INTERFACE-DAY"
> "DATE-INTERFACE-MONTH"
> "DATE-INTERFACE-YEAR"
> "DATE-TIME-INTERFACE"
> "PROMPT-FOR-DATE-AND-TIME"
> "TIME-INTERFACE"
> "TIME-INTERFACE-HOUR"
> "TIME-INTERFACE-MINUTE"
> "TIME-INTERFACE-SECOND"))
> (in-package "DATE-TIME-CAPI")
>
> ;; 0 1 2 3 4 5 6 7 8
> ;; second, minute, hour, date, month, year, day, daylight-p, zone
>
> (defun first-day-of-month (month year) ; "Mon 0"
> (nth-value 6 (decode-universal-time
> (encode-universal-time 0 0 0 1 month year))))
>
> (defun days-in-month (month year)
> (ecase month
> (1 31) (2 (if (system::leap-year-p year) 29 28)) (3 31) (4 30)
> (5 31) (6 30) (7 31) (8 31) (9 30) (10 31) (11 30) (12 31)))
>
>
> ;;; ----------------------------------------------------------------------
> ;;;
> ;;;
> ;;;
>
> (capi:define-interface date-interface ()
> ((day :initform (nth-value 3 (get-decoded-time))
> :initarg :day :reader date-interface-day)
> (last-day-of-month-hack :initform nil)
> (month :initform (nth-value 4 (get-decoded-time))
> :initarg :month :reader date-interface-month)
> (year :initform (nth-value 5 (get-decoded-time))
> :initarg :year :reader date-interface-year)
> (pbuts :initform
> (loop for i below 49
> collect (make-instance 'capi:item-pinboard-object
> :print-function
> (lambda (x)
> (typecase x
> (null "")
> (string x)
> (t (princ-to-string x)))))
> into ret finally (return (apply 'vector ret))))
> (callback :initarg :callback :initform nil)
> start end)
> (:panes
> (month-pane capi:option-pane
> :selected-item month
> :items '(1 2 3 4 5 6 7 8 9 10 11 12)
> :print-function (lambda (n)
> (elt #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
> "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
> (1- n)))
> :callback-type :interface-data
> :selection-callback (lambda (intf data)
> (unless (= month data)
> (reset-calendar-date-highlight intf)
> (setq month data)
> (reset-date-interface intf)
> (when callback (funcall callback intf)))))
> (year-pane capi:text-input-range
> :value year :start 1 :end 4500 :callback-type :interface-data
> :callback (lambda (intf data)
> (unless (= year data)
> (reset-calendar-date-highlight intf)
> (setq year data)
> (reset-date-interface intf)
> (when callback (funcall callback intf)))))
> (calendar-pane capi:pinboard-layout
> :input-model '(((:button-1 :press) select-calendar-date))
> :fit-size-to-children t
> :visible-min-width 300
> :visible-min-height 150
> :description (coerce pbuts 'list)))
> (:layouts
> (row-layout capi:row-layout '(month-pane year-pane))
> (column-layout capi:column-layout '(row-layout calendar-pane)))
> (:default-initargs
> :create-callback 'reset-date-interface
> :title "Date Interface:"
> :layout 'column-layout))
>
> (defun initialize-calendar-pane (date-interface calendar-pane)
> (check-type date-interface date-interface)
> (check-type calendar-pane capi:pinboard-layout)
> (multiple-value-bind (left top right bottom)
> (gp:get-string-extent calendar-pane "XXX"
> (capi:simple-pane-font calendar-pane))
> (let ((width (- right left)) (height (- bottom top)))
> ;;(setq width (floor (* width 2)) height (floor (* height 2)))
> (with-slots (pbuts) date-interface
> (loop for i below 49 for p = (elt pbuts i)
> for (row col) = (multiple-value-list (floor i 7))
> when (< i 7) do
> (setf (capi:item-data p)
> (elt #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") i))
> do
> (capi:set-hint-table
> p (list :x (+ (* 2 col width) (floor width 2))
> :y (+ (* 2 row height) (floor height 2))
> :external-min-width width
> :external-min-height height
> :external-max-width t
> :external-max-height t))
> (setf (capi:pinboard-pane-position p)
> (values (+ (* col 2 width) (floor width 2))
> (+ (* row 2 height) (floor height 2)))
> (capi:pinboard-pane-size p)
> (values width height)))))))
>
> (defun reset-calendar-date-highlight (intf)
> "Internal."
> (check-type intf date-interface)
> (with-slots (day pbuts start calendar-pane) intf
> (capi:unhighlight-pinboard-object
> calendar-pane (elt pbuts (+ start day -1))
> :redisplay t)))
>
> (defun reset-date-interface (intf)
> "Internal."
> (check-type intf date-interface)
> (with-slots (day month year pbuts calendar-pane start end) intf
> (unless (capi:item-data (elt pbuts 0))
> (initialize-calendar-pane intf calendar-pane))
> ;;0 1 2 3 4 5 6
> ;;S M0 T W T F S
> ;;7 8 9 10 11 12 13
> (setq start (+ 7 (mod (+ (first-day-of-month month year) 8) 7))
> end (+ start (days-in-month month year)))
> (with-slots (last-day-of-month-hack) intf ;XXX
> (cond ((< (+ day start) end)
> (when (and last-day-of-month-hack
> (< last-day-of-month-hack end))
> (setq day last-day-of-month-hack)
> (setq last-day-of-month-hack nil)))
> (t (setq last-day-of-month-hack day)
> (setq day (- end start)))))
> (loop for i from 7 below 49
> for p = (elt pbuts i)
> for d = (- i start -1)
> do
> (setf (capi:item-data p)
> (if (and (<= start i) (< i end)) d))
> (if (= d day)
> (capi:highlight-pinboard-object calendar-pane p
> :redisplay t))
> (capi:redraw-pinboard-object p t))))
>
> (defun select-calendar-date (calendar-pane x y)
> "Internal."
> (check-type calendar-pane capi:pinboard-layout)
> (let ((p (capi:pinboard-object-at-position calendar-pane x y)))
> (typecase p
> (capi:item-pinboard-object
> (when (numberp (capi:item-data p))
> (let ((intf (capi:element-interface calendar-pane)))
> (check-type intf date-interface)
> (with-slots (day callback) intf
> (unless (= day (capi:item-data p))
> (reset-calendar-date-highlight intf)
> (setq day (capi:item-data p))
> (reset-date-interface intf)
> (when callback (funcall callback intf))))))))))
>
> (defun date-interface-set (self &key (redisplay t) ((:day dd)) ((:month mm))
> ((:year yy)) &aux modp)
> (check-type self date-interface)
> (when dd (check-type dd (integer 1 31)))
> (when mm (check-type mm (integer 1 12)))
> (when yy (check-type yy (integer 0))) ;TODO
> (with-slots (day month year year-pane month-pane callback) self
> (when dd
> (unless (= dd day)
> (when redisplay
> (reset-calendar-date-highlight self))
> (setq day dd)
> (setq modp t)))
> (when mm
> (unless (= mm month)
> (unless modp
> (when redisplay
> (reset-calendar-date-highlight self)))
> (setq month mm)
> (setq modp t)))
> (when yy
> (unless (= yy year)
> (unless modp
> (when redisplay
> (reset-calendar-date-highlight self)))
> (setq year yy)
> (setq modp t)))
> (unless (= year (capi:text-input-range-value year-pane))
> (setf (capi:text-input-range-value year-pane ) year))
> (unless (= month (capi:choice-selected-item month-pane))
> (setf (capi:choice-selected-item month-pane) month))
> (when modp
> (when redisplay
> (reset-date-interface self))
> (when callback (funcall callback self)))))
>
> #||
> (capi:display(setq $x (make-instance 'date-interface)))
> (date-interface-year $x)
> (date-interface-month $x)
> (date-interface-day $x)
> (date-interface-set $x :day 30)
> (date-interface-set $x :day 30 :year 1974 :month 2)
> (date-interface-set $x :month 3 :year 1974)
> (capi:display $x)
> ||#
>
>
> ;;; ----------------------------------------------------------------------
> ;;;
> ;;;
> ;;;
>
> (defun reset-time-interface (intf)
> "Internal."
> (check-type intf time-interface)
> (with-slots (callback) intf
> (when callback (funcall callback intf))))
>
> (capi:define-interface time-interface ()
> ((hour :initarg :hour :initform (nth-value 2 (get-decoded-time))
> :reader time-interface-hour)
> (minute :initarg :minute :initform (nth-value 1 (get-decoded-time))
> :reader time-interface-minute)
> (second :initarg :minute :initform (nth-value 0 (get-decoded-time))
> :reader time-interface-second)
> (callback :initarg :callback :initform nil))
> (:panes
> (hour-pane capi:text-input-range :start 0 :end 23 :value hour
> :wraps-p t :callback-type :interface-data :callback
> (lambda (intf data) (setq hour data) (reset-time-interface intf)))
> (minute-pane capi:text-input-range :start 0 :end 59 :value minute
> :wraps-p t :callback-type :interface-data :callback
> (lambda (intf data) (setq minute data) (reset-time-interface intf)))
> (second-pane capi:text-input-range :start 0 :end 59 :value second
> :wraps-p t :callback-type :interface-data :callback
> (lambda (intf data) (setq second data) (reset-time-interface intf))))
> (:layouts
> (row-layout capi:row-layout '(hour-pane minute-pane second-pane)))
> (:default-initargs
> :create-callback 'reset-time-interface
> :title "Time: HH:MM:SS"
> :layout 'row-layout))
>
> (defun time-interface-set (self &key ((:hour hh)) ((:minute mm))
> ((:second ss)) &aux modp)
> (check-type self time-interface)
> (when hh (check-type hh (integer 0 23)))
> (when mm (check-type mm (integer 0 59)))
> (when ss (check-type ss (integer 0 59)))
> (with-slots (hour minute second hour-pane minute-pane second-pane) self
> (when hh
> (unless (= hh hour)
> (setq hour hh)
> (setq modp t)))
> (when mm
> (unless (= mm minute)
> (setq minute mm)
> (setq modp t)))
> (when ss
> (unless (= ss second)
> (setq second ss)
> (setq modp t)))
> (mapcar (lambda (value pane)
> (when value
> (unless (= value (capi:text-input-range-value pane))
> (setf (capi:text-input-range-value pane) value))))
> (list hour minute second)
> (list hour-pane minute-pane second-pane)))
> (when modp (reset-time-interface self)))
>
> #||
> (capi:display (setq $x (make-instance 'time-interface)))
> (time-interface-set $x :hour 10)
> (time-interface-set $x :minute 10)
> (time-interface-minute $x)
> ||#
>
>
> ;;;----------------------------------------------------------------------
> ;;;
> ;;; CAPI TIMEZONE INTERFACE FOR COMMONLISP TIMEZONES
> ;;;
>
> (defun %format-tz (zone)
> (check-type zone (rational -24 24))
> (format nil "~?" "~:[+~;-~]~2,'0d~2,'0d"
> (multiple-value-bind (hour min) (truncate zone 1)
> (list (plusp zone) (abs hour) (truncate (* 60 (abs min)))))))
>
> (defun %parse-rational (string)
> "Read [+-][0-9]*[/][0-9]*. Return a rational number. Second return value is
> a new string consisting of just the legal characters in the input specified in
> the previous regexp."
> (let (sign num den slash corrected)
> (map nil (lambda (c)
> (case c
> ((#\- #\+)
> (when (and (not sign) (not num))
> (push c corrected)
> (setq sign (ecase c (#\+ 1) (#\- -1)))))
> ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
> (cond ((not slash)
> (unless num (setq num 0))
> (push c corrected)
> (setq num (+ (* num 10) (digit-char-p c))))
> (t (unless den (setq den 0))
> (push c corrected)
> (setq den (+ (* den 10) (digit-char-p c))))))
> (#\/ (unless slash
> (push c corrected)
> (setq slash t)))))
> string)
> (let ((ret num))
> (when ret
> (when sign
> (setq ret (* sign ret)))
> (when slash
> (when den
> (unless (zerop den)
> (setq ret (/ ret den)))
> (check-type ret rational))))
> (values ret (coerce (nreverse corrected) 'string)))))
>
> (defun %signum (x)
> (if (zerop x)
> 1
> (signum x)))
>
> (defun %setf-tz (obj new-tz &optional where)
> "Optional argument WHERE indicates which slot of OBJ is triggering the
> change, and so should not be set."
> (check-type obj timezone-interface)
> (assert (and (rationalp new-tz) (<= -24 new-tz 24) (integerp (* 3600 new-tz))))
> (macrolet ((%bif (b &body body)
> `(unless (etypecase where
> (atom (eql ,b where))
> (list (find ,b where)))
> ,@body)))
> (with-slots (tz ppout hhtxt mmtxt tzinp callback) obj
> (%bif 'tz (setq tz new-tz))
> (%bif 'ppout (setf (capi:title-pane-text ppout) (%format-tz tz)))
> (multiple-value-bind (hh mm2) (truncate tz 1)
> (multiple-value-bind (mm ss) (truncate (* (abs mm2) 60) 1)
> (declare (ignore ss)) ; unfortunately
> (%bif 'hhtxt (setf (capi:text-input-range-value hhtxt) (* (- (%signum hh)) (abs hh))))
> (%bif 'mmtxt (setf (capi:text-input-range-value mmtxt) mm))))
> (%bif 'tzinp (setf (capi:text-input-pane-text tzinp) (princ-to-string tz)))
> (when callback (funcall callback obj)))))
>
> (capi:define-interface timezone-interface ()
> ((tz :initform -11/2 :accessor tz :initarg :tz)
> (callback :initarg :callback :initform nil))
> (:panes
> (ppout capi:title-pane :text (%format-tz tz))
> (sptxt capi:title-pane :text ":")
> (hhtxt capi:text-input-range :start -23 :end 23 :wraps-p t
> :value (* (- (%signum tz)) (truncate tz))
> :callback-type :interface-data
> :callback (lambda (intf hh)
> (assert (<= -23 hh 23))
> (let ((mm (capi:text-input-range-value mmtxt)))
> (assert (<= 0 mm 59))
> (%setf-tz intf
> (* (- (%signum hh))
> (+ (abs hh) (/ mm 60)))
> 'hhtxt))))
> (mmtxt capi:text-input-range :start 0 :end 59 :wraps-p t
> :value (abs (* 60 (nth-value 1 (truncate tz 1))))
> :callback-type :interface-data
> :callback (lambda (intf mm)
> (assert (<= 0 mm 59))
> (let ((hh (capi:text-input-range-value hhtxt)))
> (assert (<= -23 hh 23))
> (%setf-tz intf
> (* (- (%signum hh))
> (+ (abs hh) (/ mm 60)))
> 'mmtxt))))
> (tzinp capi:text-input-pane
> :text (princ-to-string tz)
> :help-key 'tzinp ;FIXME
> :max-characters 10
> :max-width t
> :callback (lambda (data intf)
> (funcall (capi:text-input-pane-change-callback tzinp)
> data tzinp intf 0)
> (setf (capi:text-input-pane-text tzinp)
> (princ-to-string tz)))
> :change-callback (lambda (text self intf caret)
> (declare (ignore self caret))
> (multiple-value-bind (new-tz corrected)
> (%parse-rational text)
> (unless (equal (capi:text-input-pane-text tzinp) corrected)
> (setf (capi:text-input-pane-text tzinp) corrected))
> (when (and new-tz (<= -24 new-tz 24) (integerp (* 3600 new-tz)))
> (%setf-tz intf new-tz 'tzinp))))))
> (:layouts
> (hhmm capi:row-layout '(hhtxt sptxt mmtxt) :adjust :center)
> (main-layout capi:column-layout '(ppout hhmm tzinp)))
> (:default-initargs
> :title "Common Lisp Timezone:"
> :layout 'main-layout
> :enable-tooltips t
> :help-callback
> (lambda (intf pane type help-key)
> (declare (ignore intf pane))
> (when (and (eq type :tooltip)
> (eq help-key 'tzinp))
> "time zone n. a rational multiple of 1/3600 between -24 (inclusive) and 24 (inclusive) that represents a time zone as a number of hours offset from Greenwich Mean Time. Time zone values increase with motion to the west, so Massachusetts, U.S.A. is in time zone 5, California, U.S.A. is time zone 8, and Moscow, Russia is time zone -3."))))
>
> (defmethod (setf tz) :around (new-tz (obj timezone-interface) &optional)
> (unless (= new-tz (slot-value obj 'tz))
> (%setf-tz obj new-tz)))
>
> #+nil
> (capi:display (setq $x (make-instance 'timezone-interface :tz -6 :callback (lambda (x) (warn "bzzt: ~S" x)))))
>
>
> ;;; ----------------------------------------------------------------------
> ;;;
> ;;; CAPI DATE-TIME INTERFACE
> ;;;
>
> (capi:define-interface date-time-interface ()
> ((supplied-tz :initform 0 :initarg :tz)
> (utime :initform 0 :initarg :utime)
> (callback :initarg :callback :initform nil)
> (selfstash :initform nil))
> (:panes
> (date-display capi:display-pane :text "" :title "Date/Time:"
> :max-width t)
> (tz-pane timezone-interface :tz supplied-tz
> :callback
> (lambda (intf)
> (assert (eql intf tz-pane)) ;
> (multiple-value-bind
> (second minute hour date month year weekday dstp timezone)
> (decode-universal-time utime (tz tz-pane))
> (declare (ignore weekday))
> (assert (null dstp))
> (assert (= timezone (tz tz-pane)))
> (date-interface-set date-interface :day date :month month :year year)
> (time-interface-set time-interface :hour hour :minute minute :second second)
> (setq utime (encode-universal-time
> second minute hour date month year (tz tz-pane)))
> (setf (capi:display-pane-text date-display)
> (user:date :utime utime :stream nil :tz (tz tz-pane))))
> (when callback (if selfstash (funcall callback selfstash)))))
> (time-interface time-interface :title "Time:"
> :callback
> (lambda (intf)
> (with-slots (hour minute second) intf
> (multiple-value-bind (sec min hr date mnth year wkdy dstp
> timezone)
> (decode-universal-time utime (tz tz-pane))
> (declare (ignore hr min sec wkdy))
> (assert (null dstp))
> (assert (= timezone (tz tz-pane)))
> (setq utime (encode-universal-time
> second minute hour date mnth year (tz tz-pane)))
> (setf (capi:display-pane-text date-display)
> (user:date :utime utime :stream nil :tz (tz tz-pane)))
> (when callback (if selfstash (funcall callback selfstash)))))))
> (date-interface date-interface :title "Date"
> :callback
> (lambda (intf)
> (with-slots (day month year) intf
> (multiple-value-bind (sec min hr date mnth yr wkdy dstp timezone)
> (decode-universal-time utime (tz tz-pane))
> (declare (ignore date mnth yr wkdy))
> (assert (null dstp))
> (assert (= timezone (tz tz-pane)))
> (setq utime (encode-universal-time sec min hr day month year (tz tz-pane)))
> (setf (capi:display-pane-text date-display)
> (user:date :utime utime :stream nil :tz (tz tz-pane)))
> (when callback (if selfstash (funcall callback selfstash))))))))
> (:layouts
> (output-panes capi:column-layout '(date-display tz-pane))
> (date-time-layout capi:column-layout
> '(date-interface time-interface output-panes)))
> (:default-initargs
> :create-callback
> (lambda (intf)
> (check-type intf date-time-interface)
> (with-slots (selfstash) intf
> (setq selfstash intf)))
> :layout 'date-time-layout))
>
> (defmethod initialize-instance :after ((intf date-time-interface) &key)
> (with-slots (utime) intf
> (date-time-interface-set intf :time utime)))
>
> #+nil
> (capi:display (setq $x (make-instance 'date-time-interface
> :callback (lambda (x) (warn "~S" x)))))
>
>
> ;;; ----------------------------------------------------------------------
> ;;;
> ;;;
> ;;;
>
> (defun extract-properties (plist indicator-list &aux ret)
> "Internal. Cannot use NIL as indicator."
> (loop (multiple-value-bind (indicator value tail)
> (get-properties plist indicator-list)
> (if indicator (setq ret (cons indicator (cons value ret))))
> (if (endp tail) (return ret))
> (setq plist (cddr tail)))))
>
> (defun date-time-interface-set (self &rest keys &key time day month year
> hour minute second (tz nil tz-supplied-p))
> (declare (ignore day month year hour minute second))
> (check-type self date-time-interface)
> (when time (check-type time (integer 0)))
> (when tz (check-type tz (rational -12 12))) ;TODO
> (when time
> (unless tz (setq tz (tz (slot-value self 'tz-pane))))
> (multiple-value-bind (ss mm hh dt mon yr wkdy dstp timezone)
> (decode-universal-time time tz)
> (declare (ignore wkdy))
> (assert (null dstp))
> (assert (= timezone tz))
> (setf (getf keys :hour) (setq hour hh))
> (setf (getf keys :minute) (setq minute mm))
> (setf (getf keys :second) (setq second ss))
> (setf (getf keys :month) (setq month mon))
> (setf (getf keys :year) (setq year yr))
> (setf (getf keys :day) (setq day dt))))
> (when keys
> (with-slots (date-interface time-interface) self
> (apply #'date-interface-set date-interface
> (append '(:redisplay nil)
> (extract-properties keys '(:month :day :year))))
> (apply #'time-interface-set time-interface
> (extract-properties keys '(:second :minute :hour)))))
> (when tz-supplied-p
> (setf (tz (slot-value self 'tz-pane)) tz)))
>
> (defun prompt-for-date-and-time (&optional (title "Select Date:") &rest keys)
> "KEYS accepted: TZ is a common lisp timezone. TIME is a common lisp
> universal time which overrides the HOUR MINUTE SECOND DAY MONTH YEAR keys
> which can also be specified."
> (let ((x (make-instance 'date-time-interface)))
> (apply #'date-time-interface-set x keys)
> (capi:popup-confirmer
> x title
> :ok-function #'(lambda (intf)
> (declare (ignore intf))
> (slot-value x 'utime)))))
>
> #+nil
> (prompt-for-date-and-time "Foo" :time 3336371200 :tz -11/2)
>
> ;;; TODO: parse-time:parse-time text-input-pane
>
> _______________________________________________
> Lisp Hug - the mailing list for LispWorks users
> lisp-hug@lispworks.com
> http://www.lispworks.com/support/lisp-hug.html
>
_______________________________________________
Lisp Hug - the mailing list for LispWorks users
lisp-hug@lispworks.com
http://www.lispworks.com/support/lisp-hug.html
* Camille Troillard <5CB0219F-1EEB-4C93-9B88-44EDAD751093@osculator.net> :
Wrote on Mon, 12 Aug 2013 09:56:31 +0200:
| I can't compile this code because of :
|
| (user:date :utime utime :stream nil :tz (tz tz-pane))
|
| Do you know how to define this date function?
I apologize for not having cleaned up that code before posting. I'm
appending the definiton I used for DATE, --- Regards, Madhu
(defun USER::date (&key (stream *standard-output*) (utime (get-universal-time)) tz
uutime)
(when uutime
(when utime (warn "ignoring UTIME using UUTIME"))
(setq utime (+ +unix-epoch+ uutime)))
(multiple-value-bind (second minute hour date month year day daylight-p zone)
(if tz
(decode-universal-time utime tz)
(decode-universal-time utime))
(when daylight-p (decf zone)) ; check
(format stream "~a ~a ~2,' d ~2,'0d:~2,'0d:~2,'0d ~4d ~?"
(ecase day
(0 "Mon") (1 "Tue") (2 "Wed") (3 "Thu") (4 "Fri")
(5 "Sat") (6 "Sun"))
(ecase month
(1 "Jan") (2 "Feb") (3 "Mar") (4 "Apr") (5 "May") (6 "Jun")
(7 "Jul") (8 "Aug") (9 "Sep") (10 "Oct") (11 "Nov") (12 "Dec"))
date hour minute second year
"~:[+~;-~]~2,'0d~2,'0d"
(multiple-value-bind (hour min) (truncate zone 1)
(list (plusp zone) (abs hour) (* 60 (abs min)))))))
_______________________________________________
Lisp Hug - the mailing list for LispWorks users
lisp-hug@lispworks.com
http://www.lispworks.com/support/lisp-hug.html
[Trying again to post an appropriate definition of DATE and fix another
bug...]
* Camille Troillard <5CB0219F-1EEB-4C93-9B88-44EDAD751093@osculator.net> :
Wrote on Mon, 12 Aug 2013 09:56:31 +0200:
| I can't compile this code because of :
|
| (user:date :utime utime :stream nil :tz (tz tz-pane))
|
| Do you know how to define this date function?
I apologize for not having cleaned up that code before posting. I'm
appending the definiton I used for DATE.
I also noticed a bug in the posted dialog prompting code, in
DATE-TIME-INTERFACE-SET, where the form
"(setf (tz (slot-value self 'tz-pane)) tz)"
was evaluated later than expected. I'm appending a kludged definition
of that function that patches this. ---Regards and regrets, Madhu
(defun user::date (&key (stream *standard-output*)
(utime (get-universal-time)) tz)
(multiple-value-bind (second minute hour date month year day daylight-p zone)
(if tz
(decode-universal-time utime tz)
(decode-universal-time utime))
(when daylight-p (decf zone)) ; check
(format stream "~a ~a ~2,' d ~2,'0d:~2,'0d:~2,'0d ~4d ~?"
(ecase day
(0 "Mon") (1 "Tue") (2 "Wed") (3 "Thu") (4 "Fri")
(5 "Sat") (6 "Sun"))
(ecase month
(1 "Jan") (2 "Feb") (3 "Mar") (4 "Apr") (5 "May") (6 "Jun")
(7 "Jul") (8 "Aug") (9 "Sep") (10 "Oct") (11 "Nov") (12 "Dec"))
date hour minute second year
"~:[+~;-~]~2,'0d~2,'0d"
(multiple-value-bind (hour min) (truncate zone 1)
(list (plusp zone) (abs hour) (* 60 (abs min)))))))
(eval-when (load eval compile) (export '(user::date) :user))
(defun date-time-interface-set (self &rest keys &key time day month year
hour minute second (tz nil tz-supplied-p))
(declare (ignore day month year hour minute second))
(check-type self date-time-interface)
(when time (check-type time (integer 0)))
(when tz (check-type tz (rational -12 12))) ;TODO
(when tz-supplied-p ; XXX madhu 20130813
(setf (tz (slot-value self 'tz-pane)) tz))
(when time
(unless tz (setq tz (tz (slot-value self 'tz-pane))))
(multiple-value-bind (ss mm hh dt mon yr wkdy dstp timezone)
(decode-universal-time time tz)
(declare (ignore wkdy))
(assert (null dstp))
(assert (= timezone tz))
(setf (getf keys :hour) (setq hour hh))
(setf (getf keys :minute) (setq minute mm))
(setf (getf keys :second) (setq second ss))
(setf (getf keys :month) (setq month mon))
(setf (getf keys :year) (setq year yr))
(setf (getf keys :day) (setq day dt))))
(when keys
(with-slots (date-interface time-interface) self
(apply #'date-interface-set date-interface
(append '(:redisplay nil)
(extract-properties keys '(:month :day :year))))
(apply #'time-interface-set time-interface
(extract-properties keys '(:second :minute :hour))))))
_______________________________________________
Lisp Hug - the mailing list for LispWorks users
lisp-hug@lispworks.com
http://www.lispworks.com/support/lisp-hug.html
David McClain wrote on Sun, 11 Aug 2013 10:18:03 -0700 21:18: | It is becoming more frequently the case that having a little Calendar | widget available to the user in GUI's would be vary convenient to have. | Has anyone seen one of those for Lisp? I have written one quite a while ago http://en.ystok.ru/products/ywidgets/ As I have no time to provide docs for Ystok-Widgets Professional Edition, I am thinking of releasing it "in small pieces" by inquiry. If you wanted to dig into large sources, I would be pleased to send them in private E-Mail. -- Sincerely, Dmitry Ivanov lisp.ystok.ru _______________________________________________ Lisp Hug - the mailing list for LispWorks users lisp-hug@lispworks.com http://www.lispworks.com/support/lisp-hug.html