Page 1 of 1

All the console goodies you ever wanted

Posted: Thu Jun 15, 2006 3:37 am
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)
))

Posted: Mon Jun 19, 2006 6:56 pm
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"?
:-)

Posted: Tue Jun 20, 2006 7:15 am
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.

Posted: Tue Jun 20, 2006 8:20 am
by alex
Yes! I said about analogy of ANSI.SYS.

Posted: Wed Jan 23, 2008 7:58 pm
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!

Posted: Wed Jan 23, 2008 8:55 pm
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

Posted: Wed Jan 23, 2008 9:27 pm
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.

Posted: Thu Jan 24, 2008 6:53 pm
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.

Posted: Fri Jan 25, 2008 1:40 am
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!!!

Re: All the console goodies you ever wanted

Posted: Wed May 31, 2017 4:01 pm
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)
    ))

Re: All the console goodies you ever wanted

Posted: Thu Jun 01, 2017 2:01 am
by TedWalther
Thank you, Bob the CaveGuy.

Re: All the console goodies you ever wanted

Posted: Fri Jun 02, 2017 2:39 pm
by Lutz