All the console goodies you ever wanted

Machine-specific discussion
Unix, Linux, OS X, OS/2, Windows, ..?
Locked
William James
Posts: 58
Joined: Sat Jun 10, 2006 5:34 am

All the console goodies you ever wanted

Post by William James »

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.
Top
alex
Posts: 100
Joined: Thu Mar 10, 2005 2:27 pm
Location: Russia

Post by alex »

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"?
:-)
Top
William James
Posts: 58
Joined: Sat Jun 10, 2006 5:34 am

Post by William James »

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.
Top
alex
Posts: 100
Joined: Thu Mar 10, 2005 2:27 pm
Location: Russia

Post by alex »

Yes! I said about analogy of ANSI.SYS.
Top
xytroxon
Posts: 296
Joined: Tue Nov 06, 2007 3:59 pm
Contact:
Contact xytroxon

Post by xytroxon »

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

Post by Lutz »

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
Top
cormullion
Posts: 2038
Joined: Tue Nov 29, 2005 8:28 pm
Location: latiitude 50N longitude 3W
Contact:
Contact cormullion

Post by cormullion »

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.
Top
m35
Posts: 171
Joined: Wed Feb 14, 2007 12:54 pm

Post by m35 »

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.
Top
xytroxon
Posts: 296
Joined: Tue Nov 06, 2007 3:59 pm
Contact:
Contact xytroxon

Post by xytroxon »

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!!!
Top
CaveGuy
Posts: 112
Joined: Sun Oct 13, 2002 3:00 pm
Location: Columbus Ohio
Contact:
Contact CaveGuy

Re: All the console goodies you ever wanted

Post by CaveGuy »

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.
Top
TedWalther
Posts: 608
Joined: Mon Feb 05, 2007 1:04 am
Location: Abbotsford, BC
Contact:
Contact TedWalther

Re: All the console goodies you ever wanted

Post by TedWalther »

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

Re: All the console goodies you ever wanted

Post by Lutz »

Added a link to this page http://www.newlisp.org/index.cgi?Tips_and_Tricks
Top
Locked

Return to “newLISP and the O.S.”