All the console goodies you ever wanted

Machine-specific discussion
Unix, Linux, OS X, OS/2, Windows, ..?

All the console goodies you ever wanted

Postby William James » Thu Jun 15, 2006 3:37 am

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 all
newlisp w32cons.lsp test

Code: Select all
#
#  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)
))
Last edited by William James on Fri Jun 23, 2006 6:57 pm, edited 1 time in total.
William James
 
Posts: 58
Joined: Sat Jun 10, 2006 5:34 am

Postby alex » Mon Jun 19, 2006 6:56 pm

It is nice idea! I have small addition:
Code: Select all
# MicroSoft help about console functions:
# http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dllproc/base/console_functions.asp
(import "kernel32.DLL" "SetConsoleTitleA")
(import "kernel32.DLL" "GetConsoleTitleA")
(define (cons-title-set title) (SetConsoleTitleA title))
(define (cons-title-get , buff)
  (setq buff (dup "\000" 32001))
  (GetConsoleTitleA (address buff) 32000)
  buff)


Can anybody write (ANSI-print)-function, based on "this-topic-code"?
:-)
alex
 
Posts: 100
Joined: Thu Mar 10, 2005 2:27 pm
Location: Russia

Postby William James » Tue Jun 20, 2006 7:15 am

You mean something like a replacement for ANSI.SYS that could be used for displaying ANSI pictures? I wrote a program in Pascal that serves that purpose; it could be translated to newLISP.
William James
 
Posts: 58
Joined: Sat Jun 10, 2006 5:34 am

Postby alex » Tue Jun 20, 2006 8:20 am

Yes! I said about analogy of ANSI.SYS.
alex
 
Posts: 100
Joined: Thu Mar 10, 2005 2:27 pm
Location: Russia

Postby xytroxon » Wed Jan 23, 2008 7:58 pm

Hello newLISP fans!

I am a newLISP newbie and was trying out the above console code. I cut and paste the above code and I don't see any obvious things wrong or missing. To a newbie of course ;)

I am using newLISP v.9.2.17 on Win 98se.

And running: newlisp w32cons.lsp test

Gives the error condition: target cannot be MAIN in function def-new

I believe the problem lies with this code:

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

But I am not sure I understand how to resolve this conflict.

-- Thanks for your help!
xytroxon
 
Posts: 295
Joined: Tue Nov 06, 2007 3:59 pm

Postby Lutz » Wed Jan 23, 2008 8:55 pm

The w32cons.lsp file your are using was written for a newLISP version previous to v8.9.8, when that error message was added (summer 2006). Perhaps you can contact the author.

Lutz
Lutz
 
Posts: 5258
Joined: Thu Sep 26, 2002 4:45 pm
Location: Pasadena, California

Postby cormullion » Wed Jan 23, 2008 9:27 pm

Hi xytroxon! Welcome to newLISP.

I can't run or test the OP's code, since it's Windows-specific, sorry... And I'm not sure what he's doing there either. Although the manual suggests that def-new can't be used without specifying a context other than main...

newLISP is being developed at quite a rapid pace at the moment. Even code that i wrote a few months ago doesn't always run today without minor corrections. (Currently parts of my code are generating 'out of bounds' errors when run on the current development release, since I wrote sloppy code and have been caught out... :))

You'll be all right using the code in the official release, but if you see any code on this board older than say a year, or more than a version old, be prepared to do some tweaking.
cormullion
 
Posts: 2037
Joined: Tue Nov 29, 2005 8:28 pm
Location: latiitude 50N longitude 3W

Postby m35 » Thu Jan 24, 2008 6:53 pm

Welcome xytroxon.

I find it interesting that this module creates functions in the MAIN context. All other modules I've seen keep everything in its own context.

In any case, if I change
Code: Select all
;; Move cursor.
(def-new 'CONSOLE:at-xy)
to
Code: Select all
;; Move cursor.
(define at-xy CONSOLE:at-xy)

the test will run. I can't say if it runs how it's supposed to, but it looks like it's working.
m35
 
Posts: 171
Joined: Wed Feb 14, 2007 12:54 pm
Location: Carifornia

Postby xytroxon » Fri Jan 25, 2008 1:40 am

Thanks! That made it work!

This code also needs to be updated on the newLISP Fan Club Wiki.

http://www.alh.net/newlisp/wiki/index.c ... ver_Wanted

Again... Thank you!!!
xytroxon
 
Posts: 295
Joined: Tue Nov 06, 2007 3:59 pm

Re: All the console goodies you ever wanted

Postby CaveGuy » Wed May 31, 2017 4:01 pm

Code: Select all
    #
    #  module for Win32-console
    #
    # modernized 5/31/2017 by caveguy and tested
    # using newLISP v.10.7.1 64-bit on Windows
    #

    (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 term
      '(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 (term foreground)))
      (if (symbol? background)
        (setq background (term 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.
    (define (at-xy x y) (CONSOLE:at-xy x y))

    (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)
    ))
Bob the Caveguy aka Lord High Fixer.
CaveGuy
 
Posts: 112
Joined: Sun Oct 13, 2002 3:00 pm
Location: Columbus Ohio

Re: All the console goodies you ever wanted

Postby TedWalther » Thu Jun 01, 2017 2:01 am

Thank you, Bob the CaveGuy.
Cavemen in bearskins invaded the ivory towers of Artificial Intelligence. Nine months later, they left with a baby named newLISP. The women of the ivory towers wept and wailed. "Abomination!" they cried.
TedWalther
 
Posts: 602
Joined: Mon Feb 05, 2007 1:04 am
Location: Abbotsford, BC

Re: All the console goodies you ever wanted

Postby Lutz » Fri Jun 02, 2017 2:39 pm

Lutz
 
Posts: 5258
Joined: Thu Sep 26, 2002 4:45 pm
Location: Pasadena, California


Return to newLISP and the O.S.

Who is online

Users browsing this forum: No registered users and 1 guest

cron