Cursor positioning and a digital clock

Guiserver, GTK-server, OpenGL, PostScript,
HTML 5, MIDI, IDE
Locked
William James
Posts: 58
Joined: Sat Jun 10, 2006 5:34 am

Cursor positioning and a digital clock

Post by William James »

Code: Select all

(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) 
Last edited by William James on Thu Jun 15, 2006 9:37 pm, edited 6 times in total.

HPW
Posts: 1390
Joined: Thu Sep 26, 2002 9:15 am
Location: Germany
Contact:

Post by 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
>
Hans-Peter

William James
Posts: 58
Joined: Sat Jun 10, 2006 5:34 am

Post by 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 all

"Mon Jun 12 02:03:29 2006"

William James
Posts: 58
Joined: Sat Jun 10, 2006 5:34 am

Post by 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
Posts: 1390
Joined: Thu Sep 26, 2002 9:15 am
Location: Germany
Contact:

Post by HPW »

Works like a charm now. Seems my german setup.
;-)
Hans-Peter

William James
Posts: 58
Joined: Sat Jun 10, 2006 5:34 am

Post by William James »

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

cormullion
Posts: 2038
Joined: Tue Nov 29, 2005 8:28 pm
Location: latiitude 50N longitude 3W
Contact:

Post by 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 all

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
Posts: 58
Joined: Sat Jun 10, 2006 5:34 am

Post by 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
Posts: 5289
Joined: Thu Sep 26, 2002 4:45 pm
Location: Pasadena, California
Contact:

Post by Lutz »

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

Code: Select all

(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
Posts: 58
Joined: Sat Jun 10, 2006 5:34 am

Post by William James »

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

Code: Select all

> (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
Posts: 58
Joined: Sat Jun 10, 2006 5:34 am

Post by William James »

There was a bug in the time parsing. Illustration:

Code: Select all

> (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 all

  {0*(\d+):0*(\d+):0*(\d+)}
Leading zeros aren't captured.

cormullion
Posts: 2038
Joined: Tue Nov 29, 2005 8:28 pm
Location: latiitude 50N longitude 3W
Contact:

Post by cormullion »

You could always use strftime patterns:

Code: Select all

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

Locked