newlispfanclub.alh.net

Posted: **Mon Jun 12, 2006 4:06 am**

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

Posted: **Mon Jun 12, 2006 6:24 am**

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
>

Posted: **Mon Jun 12, 2006 7:05 am**

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"

Posted: **Mon Jun 12, 2006 7:52 am**

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.

Posted: **Mon Jun 12, 2006 9:31 am**

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

Posted: **Wed Jun 14, 2006 8:28 am**

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

Posted: **Wed Jun 14, 2006 12:41 pm**

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! ;-)

Posted: **Wed Jun 14, 2006 9:04 pm**

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

Posted: **Wed Jun 14, 2006 9:28 pm**

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

Posted: **Thu Jun 15, 2006 8:32 am**

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..........

Posted: **Thu Jun 15, 2006 9:33 pm**

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.

Posted: **Fri Jun 16, 2006 7:29 am**

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"

newlispfanclub.alh.net

Cursor positioning and a digital clock

Cursor positioning and a digital clock