Topics - William James

Show posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.

Show posts Menu

Topics - William James

Pages1

Whither newLISP? / lexical-let

October 06, 2013, 09:44:14 PM

Before version 24.1, EMACS Lisp was dynamically scoped; now lexical scoping

is an option. When a closure was needed, it was customary to load the

CL package and use lexical-let.

It would be very nice if lexical-let were added to newLISP. Closures

could be created more easily, by a method that is more readily

understood by users of other dialects of Lisp. It would make it easier

to demonstrate the power of newLISP to potential converts.

There is a book titled "Let over Lambda" that demonstrates the

advanced use of closures; when lexical-let is added to newLISP,

converting the code in the book will be a trivial task.

The amount of code added to the newLISP distribution would be

miniscule. It's much better to have the facility bundled with the

language rather than having to include the code for the macro when

you post an example in a forum like Stackoverflow. Brevity will make a

better impression on interested programmers.

I know that closures can be created using contexts, but it seems to me

that most programmers will find it easier to use a lexical let; they

are used to doing it that way in other Lisps and in Scheme. Since it

makes programming easier and adding it to the language would be dead

simple, it would be a shame not to include it.

To get the ball rolling, here is my attempt at an implementation.

(uuid is used instead of gensym.)

Code Select Expand
(context 'lexical-let)
(define-macro (lexical-let:lexical-let varval-pairs)
  (let (body (cons 'begin (args))
        alist (map (fn(x) (list (x 0) (sym (string 's (uuid))) (eval (x 1))))
                   (explode varval-pairs 2)))
    (bind (map rest alist))
    (dolist (x alist) (set-ref-all (x 0) body (x 1)))
    (eval body)))
(context MAIN)

;; Example

(define (make-fibber)
  (lexical-let (a 0  b 1)
    (fn() (swap a b) (++ b a) a)))

newLISP's popularity cannot be decreased, and may very well be

increased, by adding an implementation of this.

newLISP in the real world / rewrite macros for updating association-lists

October 06, 2013, 12:50:53 AM

Code Select Expand
(macro (assoc-push Alist Key Val)
  (let (key Key  val Val)
    (or
      (catch
        (push val (or (lookup key Alist) (throw nil)) -1))
      (push (list key (list val)) Alist -1))))

(macro (assoc++ Alist Key Val)
  (let (key Key  val Val)
    (or
      (catch
        (++ (or (lookup key Alist) (throw nil)) (or val 1)))
      (push (list key (or val 1)) Alist -1))))

Example:

Code Select Expand
(define (word-counts wlist)
  (let (counts '())
    (dolist (word wlist)  (assoc++ counts word))
    counts))

(word-counts (find-all "[a-z]+" (lower-case 
  {"The time has come," the Walrus said,
  "To talk of many things:
  Of shoes--and ships--and sealing-wax--
  Of cabbages--and kings--
  And why the sea is boiling hot--
  And whether pigs have wings."})))

(("the" 3) ("time" 1) ("has" 1) ("come" 1) ("walrus" 1) ("said" 1)
 ("to" 1) ("talk" 1) ("of" 3) ("many" 1) ("things" 1) ("shoes" 1)
 ("and" 5) ("ships" 1) ("sealing" 1) ("wax" 1) ("cabbages" 1)
 ("kings" 1) ("why" 1) ("sea" 1) ("is" 1) ("boiling" 1) ("hot" 1)
 ("whether" 1) ("pigs" 1) ("have" 1) ("wings" 1))

newLISP in the real world / Possible bug in sort

December 28, 2012, 09:08:22 AM

Code Select Expand

;; Function composition.
(define (f<g= f g)
  (expand (fn (a b) (f (g a) (g b))) 'f 'g))

((f<g= < last) '(a 2) '(b 3))
 ==> true

((f<g= < last) '(b 3) '(a 2))
 ==> nil

(set 'lst '((b 5) (a 2)))
(sort lst (f<g= < last))
 ==> ((a 2) (b 5))

(set 'lst '((a 2) (b 5)))
(sort lst (f<g= < last))
 ==> ((a 2) (b 5))


(set 'lst '((c 4) (b 5) (a 2)))
(sort lst (f<g= < last))

  [ crashes ]

newLISP in the real world / Macros for pipelining

April 07, 2012, 09:35:37 AM

Here are two "threading" or pipelining macros, similar to those in Clojure:

Code Select Expand

(context '->>)
(define-macro (->>:->> E form)
  (if (empty? (args))
    (if (list? form)
      (eval (push E form -1))
      (eval (list form E)))
    (eval (cons '->> (cons (list '->> E form) (args))))))

(context '->)
(define-macro (->:-> E form)
  (if (empty? (args))
    (if (list? form)
      (eval (cons (first form) (cons E (rest form))))
      (eval (list form E)))
    (eval (cons '-> (cons (list '-> E form) (args))))))

(context MAIN)

Consider this sequential application of three functions:

Code Select Expand
: (exp (sqrt (abs -3)))
5.652233674

Using one of the macros, the functions appear in the same order that they are applied and fewer parentheses are needed:

Code Select Expand

: (-> -3 abs sqrt exp)
5.652233674

The -> macro feeds the item as the first argument to the function:

Code Select Expand

: (-> 8 (div 4))
2

The ->> macro feeds the item as the last argument to the function:

Code Select Expand

: (->> 8 (div 4))
0.5

Let's extract the values from an association list, select only those that are less than 50, and add them up.

Code Select Expand
(setq alist '((a 29)(b 25)(c 21)(d 64)))
: (->> alist (map last) (filter (curry > 50)) (apply +))
75

newLISP in the real world / Yet another REPL

April 04, 2012, 03:17:40 PM

Allows you to spread your expressions over several lines.

Code Select Expand

: (
factor
99999999991

)
(83 1289 934693)

If botched input keeps the prompt from appearing, control-Z (under Windows; for Linux, try control-D) should clear up the problem:

Code Select Expand

:  * 2 3)
)
)
^Z
ERR: string expected : nil

A work in progress. Modify as you see fit.

Code Select Expand

(define (input__complete? str)
  (if (or (find "^s*$" str 0)
          (find "^s*;[^n]*$" str 0))
    true
    (let (error-message ""
          scanned 0)
      (if
        (catch
          (begin
            (read-expr str)
            (setq scanned $0))
          'error-message)
        (input__complete? (slice str scanned))
        false))))

(let ((repl__line "")
      (repl__accum '())
      (repl__expression ""))
  (do-while true
    (unless
      (catch
        (begin
          (if (null? repl__accum) (print ": "))
          (setq repl__line (read-line))
          (push repl__line repl__accum)
          (setq repl__expression
            (join (reverse (copy repl__accum)) "n"))
          (if (input__complete? repl__expression)
            (begin
              (setq repl__accum '())
              (setq repl__expression
                (read-expr (string "(begin " repl__expression ")")))
              (println (eval repl__expression)))))
        'error-message)
      (setq repl__accum '())
      (println error-message))))

newLISP in the real world / Pseudo-closures using gensym

April 01, 2012, 08:39:36 AM

Code Select Expand

(define (gensym:gensym)
  (sym (string "gensym-" (inc gensym:counter))))

(define-macro (closure varval-pairs body)
  (let (alist (map (fn(x) (list (x 0) (gensym) (eval (x 1))))
                   (explode varval-pairs 2)))
    (bind (map (fn (x) (rest x)) alist))
    (dolist (x alist)
      (set-ref-all (x 0) body (x 1)))
    body))

(set 'up-down
  (closure (a 0 b 99)
    (lambda () (list (++ a) (-- b)))))

> (up-down)
(1 98)
> (up-down)
(2 97)
> (up-down)
(3 96)

> (println up-down)
(lambda () (list (++ gensym:gensym-14) (-- gensym:gensym-15)))

newLISP and the O.S. / Text from clipboard

July 04, 2006, 10:13:01 PM

Code Select Expand

(context 'Clipboard)

(constant 'CF_TEXT 1)

(import "user32.DLL" "GetClipboardData")
(import "user32.DLL" "OpenClipboard")
(import "user32.DLL" "CloseClipboard")
# (import "user32.DLL" "SetClipboardData")

(import "kernel32.DLL" "GlobalLock")
(import "kernel32.DLL" "GlobalUnlock")


(define (get-text , result global_handle ptr)
  (set 'result "")
  (if (= 0 (OpenClipboard 0))
    (thow-error "Can't open clipboard."))
  (set 'global_handle (GetClipboardData CF_TEXT))
  (if (!= global_handle 0)
    (begin
      (set 'ptr (GlobalLock global_handle))
      (set 'result (get-string ptr))
      (GlobalUnlock global_handle)
    ))
  (CloseClipboard)
  result )

(context MAIN)

Anything else we might add? / Ruby-style iterators

July 04, 2006, 03:50:39 PM

My newLISP Sudoku program needed an iterator like this:

Code Select Expand

each_empty_cell { |row,col|
  . . . .
}

I put the definition in a context to hide the iterator's variables from the lambda it serves.

Code Select Expand

(context 'each-empty-cell)

(define (each-empty-cell:each-empty-cell func , row col)
  (dotimes (row 9)
    (dotimes (col 9)
      (if (= " " (nth row col MAIN:Board))
        (func row col)))))

(context MAIN)

Example of use:

Code Select Expand

(each-empty-cell (fn (row col)
  (set 'lst (possibles row col))
  (if (= 1 (length lst))
    (plug-in (first lst) row col))))

Anything else we might add? / Speed test: Ruby & hash tables vs. newLISP & symbols

June 29, 2006, 07:47:19 PM

Most people who adopt newLISP after using awk, Ruby, Perl, or Python are concerned about the lack of associative arrays (hash tables). So I decided to test how well newLISP's symbols in contexts compare to Ruby's hash tables. The task is to parse a file of 3,622,143 bytes that contains letters P--Q of an unabridged dictionary. The first programs simply count the number of unique words and the number of letters in those words. The second pair of programs count the number of times each word occurs.

newLISP:

Code Select Expand

(set 'start-time (time-of-day))

(while (read-line)
  (dolist (word (parse (current-line) {[^A-Za-z]+} 0))
    (if (not (empty? word))
      (sym word 'Words))))

(set 'middle-time (time-of-day))

(set 'char-count 0)
(dolist (word-sym  (symbols Words))
  (inc 'char-count  (length word-sym)))

(set 'end-time (time-of-day))

(set 'fmt "%-34s%5dn" )
(print (format fmt "Milliseconds to parse file: "
  (- middle-time start-time)))
(print (format fmt "Milliseconds to count characters: "
  (- end-time middle-time)))
(print (format fmt "Total milliseconds: "
  (- end-time start-time)))
(println (length (symbols Words)) " words; "
  char-count " characters")

Ruby:

Code Select Expand

def mil( f ); (f * 1000).to_int; end


start_time = Time.now

words = {}
while line = gets
  line.split( /[^A-Za-z]+/ ).each{ |word|

    words[ word ] = true   if not word.empty?
  }
end

middle_time = Time.now

char_count = 0
words.each_key{ |word|  char_count += word.size }

end_time = Time.now

fmt = "%-34s%5dn"
puts fmt % [ "Milliseconds to parse file:",
  mil(middle_time - start_time) ]
puts fmt % [ "Milliseconds to count characters:",
  mil(end_time - middle_time) ]
puts fmt % [ "Total milliseconds: ",
  mil(end_time - start_time) ]
puts "#{ words.size } words; #{ char_count } characters"

Code Select Expand

Ruby:
Milliseconds to parse file:       11646
Milliseconds to count characters:   121
Total milliseconds:               11767
40821 words; 304947 characters

newLISP:
Milliseconds to parse file:        5538
Milliseconds to count characters:    70
Total milliseconds:                5608
40821 words; 304947 characters

newLISP:

Code Select Expand

(set 'start-time (time-of-day))

(while (read-line)
  (dolist (word (parse (current-line) {[^A-Za-z]+} 0))
    (if (not (empty? word))
      (if (sym word 'Words nil)
        (inc (sym word 'Words))
        (context 'Words word 1)))))

(set 'middle-time (time-of-day))

(set 'word-count 0)
(dolist (word-sym  (symbols 'Words))
  (inc 'word-count (eval word-sym)))

(set 'end-time (time-of-day))

(set 'fmt "%-34s%5dn" )
(print (format fmt "Milliseconds to parse file: "
  (- middle-time start-time)))
(print (format fmt "Milliseconds to count words: "
  (- end-time middle-time)))
(print (format fmt "Total milliseconds: "
  (- end-time start-time)))
(println word-count " words; " (length (symbols 'Words))
  " unique words")

Ruby:

Code Select Expand

def mil( f ); (f * 1000).to_int; end

start_time = Time.now

words = Hash.new( 0 )
while line = gets
  line.split( /[^A-Za-z]+/ ).each{ |word|
    words[ word ] += 1   if not word.empty?
  }
end

middle_time = Time.now

word_count = 0
words.each_value{ |cnt|  word_count += cnt }

end_time = Time.now

fmt = "%-34s%5dn"
puts fmt % [ "Milliseconds to parse file:",
  mil(middle_time - start_time) ]
puts fmt % [ "Milliseconds to count words:",
  mil(end_time - middle_time) ]
puts fmt % [ "Total milliseconds: ",
  mil(end_time - start_time) ]
puts "#{ word_count } words; #{ words.size } unique words"

Code Select Expand

Ruby:
Milliseconds to parse file:       11827
Milliseconds to count words:         80
Total milliseconds:               11907
662846 words; 40821 unique words

newLISP:
Milliseconds to parse file:        6930
Milliseconds to count words:         60
Total milliseconds:                6990
662846 words; 40821 unique words

Keep in mind that Ruby is slower than Python and Perl.

#10

Anything else we might add? / sym and context

June 29, 2006, 11:11:58 AM

Code Select Expand
newLISP v.8.9.0 on Win32 MinGW, execute 'newlisp -h' for more info.

> (while (read-line)(dolist (word (parse (current-line)))(sym word 'HT)))
It was a dark
and stormy night.
^Z
HT:night.
> (context HT) (symbols)
HT
(It a HT:and dark night. stormy was)
HT>

Why is it HT:and instead of and?

#11

Anything else we might add? / Evaluation order in map

June 24, 2006, 08:29:42 PM

Is it guaranteed that map will apply the function to the list elements in left-to-right order? Will

Code Select Expand
(map print (sequence 5 8))

always produce

Code Select Expand
5678

?

In Scheme, the order is unspecified. SRFI 1 proposes map-in-order, which works from left to right.

#12

newLISP and the O.S. / All the console goodies you ever wanted

June 14, 2006, 08:37:09 PM

Now you can

Get the dimensions of the console window

Detect a key press

Get the color attribute currently used when printing

Hide the cursor

Change the height of the cursor

Read text from the screen

Read color attributes from the screen

And of course you can move the cursor anywhere you want and print with any available color.

To make the included demo run:

Code Select Expand
newlisp w32cons.lsp test

Code Select Expand

#
#  module for Win32-console
#

(context 'CONSOLE)

(import "kernel32.DLL" "GetStdHandle")
(import "kernel32.DLL" "SetConsoleTextAttribute")
(import "kernel32.DLL" "SetConsoleCursorPosition" )
(import "kernel32.DLL" "GetConsoleScreenBufferInfo" )
(import "kernel32.DLL" "ReadConsoleOutputCharacterA" )
(import "kernel32.DLL" "ReadConsoleOutputAttribute" )
(import "kernel32.DLL" "SetConsoleCursorInfo" )
(import "kernel32.DLL" "GetConsoleCursorInfo" )
(import "msvcrt.DLL"   "_kbhit" )


(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))
    (sequence 0 15 ))))

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

;  Get a string of characters from the screen.
(define (get-text x y num , buffer num-read)
  (setq buffer (dup " " num))
  (setq num-read (dup " " 4))
  (if (= 0 (ReadConsoleOutputCharacterA (cons-output-handle)
            buffer num (+ x (<< y 16)) num-read))
      nil
      (slice buffer 0 (first (unpack "lu" num-read)))))

;  Get a list of console attributes (colors).
(define (get-attributes x y num , buffer num-read)
  (setq buffer (dup " " (* 2 num))) # 2 bytes per cell
  (setq num-read (dup " " 4))
  (if (= 0 (ReadConsoleOutputAttribute (cons-output-handle)
        buffer num (+ x (<< y 16)) num-read))
      nil
      (map (fn (n) (& n 0xff))
        (unpack (dup "u" (first (unpack "lu" num-read))) buffer))))


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


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

;;  Height is percent (1--100).
(define (set-cursor-height height , buffer)
  (setq buffer (pack "lu c" height (last (get-cursor-info))))
  (< 0 (SetConsoleCursorInfo (cons-output-handle) buffer)))


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


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


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

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


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


;;  ----  Back to MAIN context.  ----

(context 'MAIN)

(define (key-pressed?)
  (!= 0 (CONSOLE:_kbhit)))

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


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

;; Get cursor position.  Upper left is (0 0).
(define (get-xy)
  (slice (CONSOLE:get-console-info) 2 2))

;; Move cursor.
(def-new 'CONSOLE:at-xy)

(define (cls , width height i)
  (map set '(width height) (get-console-size))
  (at-xy 0 0)
  (dotimes (i height)
    (print (dup " " width)))
  (at-xy 0 0))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  Test code
;;  To make this run, invoke in this manner:
;;  newlisp w32cons.lsp test
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(if (and (= "test" (last (main-args)))
         (= 3 (length (main-args))) )
(begin

  (set 'old-attr (CONSOLE:get-current-attribute))
  (console-colors)
  (cls)
  (CONSOLE:hide-cursor)

  ;;  To test the clamping, we make the background
  ;;  color range from -1 to 16 instead of from
  ;;  0 to 15.
  (for (back -1 16)
    (at-xy 0 (+ 1 back))
    (dotimes (fore 16)
      (console-colors fore back)    
      (print (format "%02d@%02d" fore back))))
  (console-colors)
  (println)

  (print "Press a key.")
  (setq coords '(10 27 0 17))
  (setq mappings '((0 2) (1 2) (0 3) (1 3)))
  (setq deltas '(1 -1 1 -1))
  (setq chars (map char '(6 5 4 3)))
  (setq span 4)
  (do-until (key-pressed?)
    (setq texts '())   (setq colors '())
    (dotimes (i 4)
      (map set '(x y) (select coords ( mappings i)))
      (push  (CONSOLE:get-text x y span) texts -1)
      (push (CONSOLE:get-attributes x y span) colors -1)
      (console-colors (if (> i 1) "LRED" "BLA") "LWHI")
      (at-xy x y) (print (dup (chars i) span)))
    (sleep 400)
    (dotimes (i 4)
      (map set '(x y) (select coords ( mappings i)))
      (at-xy x y)
      (setq text (texts i))
      (dotimes (j span) (CONSOLE:set-attribute ((colors i)j))
        (print (text j))))
    (setq coords (map + coords deltas))
    (if (or (= (last coords) 0) (> (last coords) 16))
      (rotate deltas))
  )
  (read-key)
  (CONSOLE:set-attribute old-attr)
  (cls)
  (CONSOLE:show-cursor)
  (exit)
))

#13

newLISP Graphics & Sound / Cursor positioning and a digital clock

June 11, 2006, 09:06:15 PM

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)

Pages1

newLISP Fan Club

News:

Show posts

Topics - William James

Whither newLISP? / lexical-let

newLISP in the real world / rewrite macros for updating association-lists

newLISP in the real world / Possible bug in sort

newLISP in the real world / Macros for pipelining

newLISP in the real world / Yet another REPL

newLISP in the real world / Pseudo-closures using gensym

newLISP and the O.S. / Text from clipboard

Anything else we might add? / Ruby-style iterators

Anything else we might add? / Speed test: Ruby & hash tables vs. newLISP & symbols

Anything else we might add? / sym and context

Anything else we might add? / Evaluation order in map

newLISP and the O.S. / All the console goodies you ever wanted

newLISP Graphics & Sound / Cursor positioning and a digital clock