Cursor positioning and a digital clock

[William James]

Code Select Expand

(context 'CONSOLE)

(import "kernel32.DLL" "GetStdHandle")
(import "kernel32.DLL" "SetConsoleTextAttribute")
(import "kernel32.DLL" "SetConsoleCursorPosition" )
(import "kernel32.DLL" "GetConsoleScreenBufferInfo" )
(import "kernel32.DLL" "SetConsoleCursorInfo" )
(import "kernel32.DLL" "GetConsoleCursorInfo" )

(constant 'STD_OUTPUT_HANDLE 0xfffffff5)

(setq colors (transpose   (list (map name
  '(BLA BLU GRE CYA RED MAG YEL WHI LBLA LBLU LGRE
    LCYA LRED LMAG LYEL LWHI))
  '(0x0 0x1 0x2 0x3 0x4 0x5 0x6 0x7 0x8 0x9 0xA 0xB
    0xC 0xD 0xE 0xF) )))

(define (cons-output-handle)
  (GetStdHandle STD_OUTPUT_HANDLE))


;;  Returns (cursor-height(1--100%) visible)
(define (get-cursor-info , buffer)
  (setq buffer (dup " " 5))
  (if (= 0 (GetConsoleCursorInfo (cons-output-handle) buffer))
    nil
    (unpack  "lu c" buffer)))

(define (hide-cursor , buffer)
  (setq buffer (pack "lu c" (first (get-cursor-info)) 0))
  (< 0 (SetConsoleCursorInfo (cons-output-handle) buffer)))

(define (show-cursor , buffer)
  (setq buffer (pack "lu c" (first (get-cursor-info)) -1))
  (< 0 (SetConsoleCursorInfo (cons-output-handle) buffer)))

(define (get-console-info , buffer)
  (setq buffer (dup " " 22))
  (GetConsoleScreenBufferInfo (cons-output-handle) buffer)
  (unpack  "uuuuudddduu" buffer))

;; (width height)
(define (get-console-size)
  (slice (get-console-info) 0 2))

;  Get the attribute that is currently used when writing.
(define (get-current-attribute)
  (& 0xff ((get-console-info) 4)))

 
(define (set-attribute attr)
  (SetConsoleTextAttribute
    (cons-output-handle) attr))

(define (set-cursor-position position)
  (SetConsoleCursorPosition
    (cons-output-handle) position))

; Make sure that 0 <= x <= 15.
(define (clamp x)
  (int (max 0 (min 15 x))))

; Arguments can be strings or integers.
; Default arguments:  7  0
(define (console-colors foreground background)
  (setq foreground (or foreground 7))
  (setq background (or background 0))
  (setq foreground (or (lookup foreground colors)
    (clamp foreground)))
  (setq background (or (lookup background colors)
    (clamp background)))
  (set-attribute (| (<< background 4) foreground)))


(context 'MAIN)

; Arguments can be symbols, strings, or integers.
; Examples: (console-colors 7 0)
;           (console-colors 'LYEL 'LBLA)
;           (console-colors "LMAG" "BLA")
(define (console-colors fore back)
  (if (symbol? fore)
    (setq fore (name fore)))
  (if (symbol? back)
    (setq back (name back)))
  (CONSOLE:console-colors
    fore back))

(define (at-xy x y)
  (setq x (max x 0))
  (setq y (max y 0))
  (CONSOLE:set-cursor-position
    (| (<< y 16) x)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(set 'foreground 9)
(set 'background "BLA")
(constant 'char-width 5)
(constant 'seg-height 3)
(constant 'seg-char (char 219))
(constant 'colon-char (char 177))
(constant 'x-offset 2)
(constant 'y-offset 2)
(setq char-height (+ 3 (* 2 seg-height)))

(setq patterns
  '(("0" 4 3 3 3 4)
    ("1" 5 5 5 5 5)
    ("2" 4 1 4 2 4)
    ("3" 4 1 4 1 4)
    ("4" 3 3 4 1 1)
    ("5" 4 2 4 1 4)
    ("6" 4 2 4 3 4)
    ("7" 4 1 1 1 1)
    ("8" 4 3 4 3 4)
    ("9" 4 3 4 1 1)))

(set 'slices '())
(dotimes (num 4)
  (setq tmp  (replace "1"
    (nth num '("  " " 1" "1 " "11") ) seg-char))
  (setq slices (append slices (list
    (append (first tmp)
      (dup " " (- char-width 2)) (last tmp))))))
(setq slices (append slices
  (list (dup seg-char char-width))))
(setq slices (append slices (list
  (set-nth (/ char-width 2) (dup " " char-width)
    seg-char))))

(define (make-shape chr , pattern the-shape num tmp)
  (setq pattern (1 (assoc chr patterns)))
  (setq the-shape '())
  (dotimes (i 5)
    (setq num (pattern i))
    (dotimes (ht (if (= 0 (% i 2)) 1 seg-height))
      (setq the-shape (append
        the-shape (list (nth num slices))))))
  the-shape)

(setq shapes '())
(dotimes (i 10)
  (setq shapes (append shapes (list
    (make-shape (char (+ i (char "0"))))))))

(setq am-pm
  (map (fn (lst) (append
          (dup "" (- char-height (length lst)) true)
          (map (fn (str) (replace "@" str seg-char)) lst)))
    '((
    "@@@@"
    "@  @"
    "@@@@"
    "@  @"
    "@  @" )
    (
    "@@@@"
    "@  @"
    "@@@@"
    "@   "
    "@   " ))))

(define (join-time lst , str i)
  (setq str (join lst "  "))
  ; Add extra room for "colons".
  (for (i 4 2 -2)
    (nth-set (- (* i (+ char-width 2)) 1) str "  " ))
  str)

(define (make-picture str hour , shape-lst)
  (setq shape-lst
    (append
      (select shapes
        (map (fn (c) (- (char c) (char "0")))
          (explode str)))
      (list (nth (/ hour 12) am-pm))))
  (map join-time (transpose shape-lst)))

(define (show-picture lst , x y delta-x i str)
  ; Location of "colons" between digits.
  (setq x (+ x-offset (* char-width 2) 3))
  (setq y (+ y-offset seg-height))
  (setq delta-x (* 2 (+ char-width 2))) (inc 'delta-x)
  (console-colors foreground background)
  (dolist (str lst)
    (println (dup " " x-offset) str))
  ; Place colons.
  (console-colors foreground (- foreground 1))
  (dotimes (i 2)
    (at-xy x y)
    (print colon-char)
    (at-xy x (+ 2 y))
    (print colon-char)
    (inc 'x delta-x)))

(define (next-color color)
  (+ (% (+ (- color 9) 1) 6) 9))

(define (get-time)
  ; Exclude leading zeros.
  (if (not (find {0*(d+):0*(d+):0*(d+)} (date) 0))
    (throw-error "Can't parse (date)!"))
  (map int (list $1 $2 $3)))


(define (clock , i hour)
  (set 'old-attr (CONSOLE:get-current-attribute))
  (console-colors foreground background)
  (CONSOLE:hide-cursor)
  (dotimes (i 100) (println " " ))
  (set 'old-time (get-time))
  (while true

    ; Wait for time to change.
    (do-while (= (setq new-time (get-time)) old-time)
      (sleep 50))
    (set 'old-time new-time)
    (setq hour (% (first new-time) 12))
    (nth-set 0 new-time (if (= 0 hour) 12 hour))

    (at-xy 0 y-offset)

    (show-picture (make-picture  (join
        (map (fn (n) (format "%02d" n)) new-time))
      (first old-time)))

    (if (= 9 (% (last new-time) 10))
      (setq foreground (next-color foreground)))
    (sleep 800)))

(define (cleanup)(at-xy 0 (+ y-offset char-height))
  (CONSOLE:set-attribute old-attr)
  (CONSOLE:show-cursor)
  (exit))
(signal 2 'cleanup)
(clock)


[HPW]

Output change to blue text and I get this error:

value expected in function format : n

called from user defined function make-picture

called from user defined function show-picture

called from user defined function clock

>

[William James]

It appears that the list new-time does not contain 3 integers as it should.  I suspect that on your system the string produced by (date) is different in format.  On my system:

Code Select Expand

"Mon Jun 12 02:03:29 2006"

[William James]

I modified the original post so that it should be able to parse the ouput of (date) correctly if hh:mm:ss is contained within it.  In the event that the parsing fails, an error is thrown.

[HPW]

Works like a charm now. Seems my german setup.

;-)

[William James]

Added 3 lines at the end to set sane colors when you hit CTRL-C to end the program.

[cormullion]

Nice job! I was looking at the code thinking that it would be nice to get it running on MacOS. Then I remembered that Norman has got a digital clock on his web site:

Code Select Expand

http://www.nodep.nl/downloads/newlisp/clock.lsp

I changed (sleep 1) to (sleep 1000) though...



Must try and merge the two one day! ;-)

[William James]

Now the cursor is moved to an out-of-the-way position (lower right corner), and some function names have been changed.

[Lutz]

Here is a trick to run the clock on a timer event instead of having a loop waiting for time change:

Code Select Expand


(define (clock)
    (println (date))      ;; replace with Wiliiam's clock display
    (timer 'clock 1.0))


it will save a few lines of code and burn less CPU cycles.



Lutz

[William James]

It's nifty the way timer runs in the background.

Code Select Expand


> (dotimes (i 30)(print ".")(sleep 100))
..............................
> (setq ycnt 0)
> (define (y)(print "Y")(if(< (inc 'ycnt) 3)(timer 'y .3)))
> (timer 'y 1.2) (dotimes (i 30)(print ".")(sleep 100))
............Y....Y....Y..........


[William James]

There was a bug in the time parsing.  Illustration:

Code Select Expand


> (map int '("11" "08" "55"))
(11 0 55)

The "08" is considered octal because it starts with "0".

Changed the regular expression to

Code Select Expand


 {0*(d+):0*(d+):0*(d+)}

Leading zeros aren't captured.

[cormullion]

You could always use strftime patterns:

Code Select Expand

> (date (date-value) 0 "%H %M %S")
"08 27 31"
> (date (date-value) 0 "%l %M %S")
" 8 27 43"