LispForum • Language agnostic graphics (Project in CL + LTK)

Page 1 of 2

Language agnostic graphics (Project in CL + LTK)

Posted: Sun Oct 13, 2013 9:43 pm

by Pixel_Outlaw

So some time ago I was wondering about writing a language agnostic graphics terminal.
My plans fell a bit short and I was only able to product a display device.

This is not complete yet but supports drawing.
Right now it just reads a file with commands and produces the shapes.
Eventually I will enable the program to receive "piped" commands so you'll not need to produce a file.

Q: Why did I make this?
A: Well some languages (especially very old or archaic ones) were designed before graphics terminals were popular. This gives people a way to draw static graphics (think science data) without having to resort to building libraries at the system level.

Q: Why are you not blitting shapes to a canvas?
A: I'm using LTK, it's canvas object demands shapes be stored in memory.
(might move to displaying bitmaps later)

Q: But we can already draw shapes in CL right? This isn't really needed.
A: Yes but this goes beyond that, any language can now draw shapes without libraries.
Even horrible ones.

Q: Ok you're just loading shapes from a file. Not a spectacular feat.
A: For now yes, however eventually I will enable command piping for Linux/Unix OS's.
This means you can just pipe the commands into the display rather than have to export them to file.

Here are the commands for drawing, (each one must be on it's own line in the source file)
Also, please only use whole numbers in drawing commands.
I've not yet accounted for floats and fractions. Use ROUND or FLOOR if need be before feeding commands in.

Code: Select all

All commands occupy a single line!
All color triplets range from 0 to 255
State setting commands are uppercase, drawing are lowercase
example
l 12 12 33 34 
Draws a line from (12, 12) to (33, 34)

Set pen color (red green blue)
P

Set brush color (red green blue)
B

Use filled brush (0 for false 1 for true)
U

Set pen width (number)
W

Set canvas color (red green blue)
C

Draw line (x1 y1 x2 y2)
l

Draw rectangle (x1 y1 x2 y2)
r

Draw triangle (x1 y1 x2 y2 x3 y3)
t

Draw polygon (x1 y1 x2 y2 x3 y3 ...)
p - create-polygon

Draw oval (x1 y1 x2 y2)
o

Enough already here is my current source code:

Code: Select all

;;; Ryan Burnside 2013 graphics terminal.

(load "ltk.fasl")
(in-package :ltk)

;;; Some global parameters
(defparameter *pen-color* "#ffffff")
(defparameter *brush-color* "#aaaaaa")
(defparameter *canvas-color* "#000000")
(defparameter *pen-width* 1)

;; This function toggles using the brush to fill shapes (boolean)
(defparameter *use-brush* 1) 

;; Make a lookup table binding LTK shape symbols to regex symbols
(defparameter *shape-lookup* '((#\P . set-pen-color)
			       (#\B . set-brush-color)
			       (#\U . set-use-brush)
			       (#\W . set-pen-width)
			       (#\C . set-canvas-color)
			       (#\l . create-line)
			       (#\r . create-rectangle-cords)
			       (#\t . create-polygon)
			       (#\p . create-polygon)
			       (#\o . create-oval-cords)))

(defun set-pen-color (col)
  (setf *pen-color* col))

(defun set-brush-color (col)
  (setf *brush-color* col))

(defun set-canvas-color (col canvas)
  (configure canvas :background col))

(defun set-pen-width (width)
  (setf *pen-width* width))

(defun set-use-brush (zero-or-one)
  (if (= zero-or-one 0)
      (setf *use-brush* nil)
      (setf *use-brush* t)))

(defun create-oval-cords (canvas cords)
  "Substitute function, takes a cords list"
  (make-oval canvas (nth 0 cords) 
	            (nth 1 cords) 
	            (nth 2 cords) 
	            (nth 3 cords)))

(defun create-rectangle-cords (canvas cords)
  "Substitute function, takes a cords list"
  (make-rectangle canvas (nth 0 cords) 
		         (nth 1 cords) 
		         (nth 2 cords) 
		         (nth 3 cords)))

(defun make-color (r g b)
  "Returns a hex color string given 3 parameters 0-255 per channel"
  (format nil "#~2,'0X~2,'0X~2,'0X" r g b))

(defun make-color2 (RGB-list)
  "Returns a hex color string given 3 parameters 0-255 per channel in a list"
  (format nil "#~2,'0X~2,'0X~2,'0X" (nth 0 RGB-list)
                                    (nth 1 RGB-list)
				    (nth 2 RGB-list)))

(defun tokenize-string (string)
  "Returns a list of items delimited by #\Space"
  (loop for start = 0 then (1+ finish)
     for finish = (position #\Space string :start start)
     collecting (subseq string start finish)
     until (null finish)))

(defun parse-line (line canvas-object)
   "Parses the line, maps the first letter to a drawing funciton,
     turns the args into a list, passes as list to drawing function"
  (let* ((str (string-trim " " line))
	 (begin (aref str 0))
	 (args (mapcar #'parse-integer (subseq (tokenize-string str) 1))))
	
    ;; If this is just a state change command exit now that it ran
    (when (equal begin #\C)
      (funcall (cdr (assoc begin *shape-lookup*)) 
	       (make-color2 args) canvas-object)
      (return-from parse-line t))

    ;; Canvas color and Use brush variables
    (when (or (equal begin #\W) (equal begin #\U))
      (funcall (cdr (assoc begin *shape-lookup*)) (car args))
      (return-from parse-line t))

    ;; Pen and Brush color setting 
    (when (or (equal begin #\P) (equal begin #\B))
      (funcall (cdr (assoc begin *shape-lookup*)) (make-color2 args))
      (return-from parse-line t))

    (let ((l (funcall (cdr (assoc begin *shape-lookup*)) canvas-object args)))

      (itemconfigure canvas-object l :fill (if *use-brush* *brush-color* ""))

      (if (not (equal begin #\l)) ; Lines don't get outline attribute
	  (itemconfigure canvas-object l :outline *pen-color*))

      (itemconfigure canvas-object l :width *pen-width*))))

(defun load-file-shapes (canvas)
  "Open a file and parse out the shapes, adding them to the global canvas"
  (with-open-file (stream (get-open-file))
    (do ((line (read-line stream nil)
               (read-line stream nil)))
        ((null line))
      (parse-line line canvas))))

(defun main-function()
  (with-ltk ()
    (let* ((frame (make-instance 'frame))
	   (sc (make-instance 'scrolled-canvas))
	   (canvas (canvas sc))
	   (m (make-menubar))
	   (mfile (make-menu m "File")))
      (make-menubutton mfile "Load File" (lambda () (load-file-shapes canvas)))
      (make-menubutton mfile "Export Canvas" (lambda () (get-save-file)))
      (make-menubutton mfile "Clear Canvas" (lambda () (clear canvas)))
      (make-menubutton mfile "Quit" (lambda () (setf *exit-mainloop* t)))
      (set-geometry *tk* 800 600 0 0)
      (wm-title *tk* "Ryan Burnside's Canvas")
      (pack frame :side :bottom)
      (pack sc :expand 1 :fill :both)
      (scrollregion canvas 0 0 800 600)
      (configure frame :relief :sunken))))

;Start program
(main-function)

Re: Language agnostic graphics (Project in CL + LTK)

Posted: Mon Oct 14, 2013 7:06 am

by edgar-rft

Preface: Every program you write for learning something is a good and neccessary program, even if others disagree.

I think I do not need to explain that (load "ltk.fasl") is not a really good idea, because the ".fasl" extension is implementation dependent and there is no guarantee that CL can find the file at all. But the project is still very small, an ASDF system definition can be written later on.

A more serious issue is that writing code in the :LTK package can easily clobber important LTK definitions so you should better write:

Code: Select all

(defpackage :my-ltk-package
  (:use :cl :ltk))

(in-package :my-ltk-package)

(:use :cl :ltk) means that you can still use all CL and LTK functions with no need for cl: or ltk: prefixes.

But instead of nagging around I wanted to tell a copletely different story.

Here is what I meant with "you can have pixel access if you put a Tk photo object on the canvas" in the #lisp irc channel a while ago. This is the standard trick if you want to write a freehand drawing program in Tcl/Tk.

Every Tcl/Tk version on every operating system can read PBM (1-bitplane), PGM (greyscale), PPM (color with more than 1 bitplane), and GIF images, where PPM is a particularly simple image format:

PPM Format Specification

Here is a CL function that creates a PPM "P3" image filled with a background color:

Code: Select all

(defun make-ppm-string (width height red green blue)
  "Return a PPM image, filled with RED/GREEN/BLUE color, as string."
  (let ((color  (format nil "~d ~d ~d" red green blue))
        (stream (make-string-output-stream)))
    (format stream "P3~%~d ~d~%255~%" width height)  ; ppm header
    (dotimes (y height)
      (dotimes (x width)
        (princ color stream)
        (if (< x (1- width))
            (princ "  " stream)))
            (terpri stream))
    (get-output-stream-string stream)))

width and height must be positive integers greater than zero and red, green, blue must be integers in range 0..255, like in your make-color function.

Here is how it works:

Code: Select all

CL-USER> (make-ppm-string 4 4 0 0 0)
"P3
4 4
255
0 0 0  0 0 0  0 0 0  0 0 0
0 0 0  0 0 0  0 0 0  0 0 0
0 0 0  0 0 0  0 0 0  0 0 0
0 0 0  0 0 0  0 0 0  0 0 0
"

This is black color in only 4x4 pixels, but it had to fit into the small code box somehow. You only need to increase the width an height parameters to get bigger images.

I haven't workd with LTK for quite a while, so here is a description how this works in Tcl/Tk.

Tcl/Tk commands and terminology:

canvas - window coordinate management framework
image - bitmap and pixmap memory management framework
bitmap - 1-bitplane image (2 colors, e.g. black/white with optional mask)
photo - image with more than 1 bitplane (more than 2 colors)

The ppm-string returned by the function above can be used in the Tcl/Tk "image create" command:

Code: Select all

image create photo <varName> -data <ppm-string>

This creates a pixmap as a Tk "photo" object, stored in the Tcl variable <varName>. The "photo" pixmap then can be put on a canvas at x/y position:

Code: Select all

<canvasPathName> create image x y -image <varName>

The "photo" object on the canvas can be manipulated pixelwise by:

Code: Select all

<varName> get x y
<varName> put x y <color>

get reads and returns a pixel color, put sets a pixel color, where the color is in #rrggbb format. More image manipulation commands are described on the Tk photo manpage.

I will try to find out how this works with LTK, but this may need some days. Will you be faster than me?

- edgar

Re: Language agnostic graphics (Project in CL + LTK)

Posted: Mon Oct 14, 2013 7:18 pm

by Pixel_Outlaw

Thanks for your help!

Much of my time on the week is take up by my day job so I don't have programming time until the weekends.

I'd welcome anyone who wants to work on this.

Re: Language agnostic graphics (Project in CL + LTK)

Posted: Tue Oct 15, 2013 10:23 am

by edgar-rft

Pixel_Outlaw wrote:Much of my time on the week is take up by my day job...

Same problem here...

Some hundred years ago (at least it seems so to me) I had an Amstrad PPC 512 MS-DOS machine with a 320x200 pixel LCD display. At that time I had lots of fun by writing little BASIC programs drawing lines and circles and similar stuff on the screen. But I also remember how limited the capabilites of such simple graphics langages were compared to OpenGL or similar 3d-rendering languages today. But nontheless I think it sounds like real fun to have a Tk plotting widget that could be remote-controlled from Common Lisp.

I just remember in the context of math notation that there is a book Turtle Geometry by Hal Abelson (author of SICP) and others that explains math and computer programming by simple turtle graphics programs. Do not laugh, the book evolves from simple turtle moves to 2d and 3d geometry and finally in the last chapter to a turtle graphics simulator of Einstein's Theory of Relativity, and everything explained in an understandable language.

If you look in the internet there are floating around PDF copies of outdated versions of the book (outdated in the sense that they aren't sold anymore, the math and the programs are still 99% the same in the newer versions).

Maybe we could try to implement some turtle moves on a Tk canvas?

I will try to make LTK work on my machine later on this evening...

- edgar

Re: Language agnostic graphics (Project in CL + LTK)

Posted: Tue Oct 15, 2013 11:34 pm

by edgar-rft

Success: Your program runs here (SBCL 1.1.12 on Debian 7.2 Wheezy) with no further problems so far.

Reading the Lisp code I suggest the following simplifications:

The FORMAT "~{ ... }~" construct can process lists, so:

Code: Select all

(defun make-color2 (RGB-list)
  "Returns a hex color string given 3 parameters 0-255 per channel in a list"
  (format nil "#~2,'0X~2,'0X~2,'0X" (nth 0 RGB-list)
                                    (nth 1 RGB-list)
                                    (nth 2 RGB-list)))

can be shortened to:

Code: Select all

(defun make-color2 (RGB-list)
  "Returns a hex color string given 3 parameters 0-255 per channel in a list"
  (format nil "#~{~2,'0X~2,'0X~2,'0X~}" RGB-list))

Processing an argument list in normal Common Lisp code is usually done with APPLY, so:

Code: Select all

(defun create-oval-cords (canvas cords)
  "Substitute function, takes a cords list"
  (make-oval canvas (nth 0 cords)
                    (nth 1 cords)
                    (nth 2 cords)
                    (nth 3 cords)))

can be shortened to:

Code: Select all

(defun create-oval-cords (canvas cords)
  "Substitute function, takes a cords list"
  (apply #'make-oval canvas cords))

The same can be done with create-rectangle-cords:

Code: Select all

(defun create-rectangle-cords (canvas cords)
  "Substitute function, takes a cords list"
  (apply #'make-rectangle canvas cords))

I'm from Germany and not a native english speaker, so I'm not sure if "cords" is a typo, because usually I read "coords" (with "oo") as abbreviation for "coordinates". Of course you are free to name your variables whatever you want.

If the programs becomes larger, the *shape-lookup* alist should be replaced by a hash-table or a string parser (if the shape has more than one character), but this not really important at the moment.

Here is the simplified version:

Code: Select all

;;; Ryan Burnside 2013 graphics terminal.

(load "ltk.fasl")
(in-package :ltk)

;;; Some global parameters
(defparameter *pen-color* "#ffffff")
(defparameter *brush-color* "#aaaaaa")
(defparameter *canvas-color* "#000000")
(defparameter *pen-width* 1)

;; This function toggles using the brush to fill shapes (boolean)
(defparameter *use-brush* 1)

;; Make a lookup table binding LTK shape symbols to regex symbols
(defparameter *shape-lookup*
  '((#\P . set-pen-color)
    (#\B . set-brush-color)
    (#\U . set-use-brush)
    (#\W . set-pen-width)
    (#\C . set-canvas-color)
    (#\l . create-line)
    (#\r . create-rectangle-cords)
    (#\t . create-polygon)
    (#\p . create-polygon)
    (#\o . create-oval-cords)))

(defun set-pen-color (col)
  (setf *pen-color* col))

(defun set-brush-color (col)
  (setf *brush-color* col))

(defun set-canvas-color (col canvas)
  (configure canvas :background col))

(defun set-pen-width (width)
  (setf *pen-width* width))

(defun set-use-brush (zero-or-one)
  (if (= zero-or-one 0)
      (setf *use-brush* nil)
      (setf *use-brush* t)))

(defun create-oval-cords (canvas cords)
  "Substitute function, takes a cords list"
  (apply #'make-oval canvas cords))

(defun create-rectangle-cords (canvas cords)
  "Substitute function, takes a cords list"
  (apply #'make-rectangle canvas cords))

(defun make-color (r g b)
  "Returns a hex color string given 3 parameters 0-255 per channel"
  (format nil "#~2,'0X~2,'0X~2,'0X" r g b))

(defun make-color2 (RGB-list)
  "Returns a hex color string given 3 parameters 0-255 per channel in a list"
  (format nil "#~{~2,'0X~2,'0X~2,'0X~}" RGB-list))

(defun tokenize-string (string)
  "Returns a list of items delimited by #\Space"
  (loop for start = 0 then (1+ finish)
        for finish = (position #\Space string :start start)
        collecting (subseq string start finish)
        until (null finish)))

(defun parse-line (line canvas-object)
   "Parses the line, maps the first letter to a drawing funciton,
     turns the args into a list, passes as list to drawing function"
  (let* ((str (string-trim " " line))
         (begin (aref str 0))
         (args (mapcar #'parse-integer (subseq (tokenize-string str) 1))))

    ;; If this is just a state change command exit now that it ran
    (when (equal begin #\C)
      (funcall (cdr (assoc begin *shape-lookup*))
               (make-color2 args) canvas-object)
      (return-from parse-line t))

    ;; Canvas color and Use brush variables
    (when (or (equal begin #\W) (equal begin #\U))
      (funcall (cdr (assoc begin *shape-lookup*)) (car args))
      (return-from parse-line t))

    ;; Pen and Brush color setting
    (when (or (equal begin #\P) (equal begin #\B))
      (funcall (cdr (assoc begin *shape-lookup*)) (make-color2 args))
      (return-from parse-line t))

    (let ((l (funcall (cdr (assoc begin *shape-lookup*)) canvas-object args)))
      (itemconfigure canvas-object l :fill (if *use-brush* *brush-color* ""))
      (if (not (equal begin #\l)) ; Lines don't get outline attribute
          (itemconfigure canvas-object l :outline *pen-color*))
      (itemconfigure canvas-object l :width *pen-width*))))

(defun load-file-shapes (canvas)
  "Open a file and parse out the shapes, adding them to the global canvas"
  (with-open-file (stream (get-open-file))
    (do ((line (read-line stream nil)
               (read-line stream nil)))
        ((null line))
      (parse-line line canvas))))

(defun main-function ()
  (with-ltk ()
    (let* ((frame (make-instance 'frame))
           (sc (make-instance 'scrolled-canvas))
           (canvas (canvas sc))
           (m (make-menubar))
           (mfile (make-menu m "File")))
      (make-menubutton mfile "Load File" (lambda () (load-file-shapes canvas)))
      (make-menubutton mfile "Export Canvas" (lambda () (get-save-file)))
      (make-menubutton mfile "Clear Canvas" (lambda () (clear canvas)))
      (make-menubutton mfile "Quit" (lambda () (setf *exit-mainloop* t)))
      (set-geometry *tk* 800 600 0 0)
      (wm-title *tk* "Ryan Burnside's Canvas")
      (pack frame :side :bottom)
      (pack sc :expand 1 :fill :both)
      (scrollregion canvas 0 0 800 600)
      (configure frame :relief :sunken))))

;Start program
(main-function)

I will try to find a way to implement some LOGO-like turtle commands in the next few days, what needs additional handling of the turtle position and rotation angle. I don't want the program to become LOGO-specific, but I think it would be fun to be able to run vector-oriented LOGO commands as well as plotting commands using rectangular x/y-coordinates.

- edgar

Re: Language agnostic graphics (Project in CL + LTK)

Posted: Wed Oct 16, 2013 8:10 pm

by Pixel_Outlaw

Thank you for cleaning up my code!
I've replaced my old copy with your additions.
Odd that you mention LOGO.
It was actually my first language as a small grade school boy.
Without knowing I was programming.
We entered LOGO commands into the Apple ][e computers in school following instructions to make things like houses and stars in LogoWriter. I recall there being a lot of green, purple and white on those machines.

I've toyed with LOGO and CL before. At one point I was making functions for turtle cursors that responded to your usual LOGO commands.
I had it export some very crude XML as SVG for viewing.
Never got around to proper control structures just simple one line commands.

Forgive this crude code, it was very early work.
(turtles store their trails internally via a series of points not sure if all commands are implimented)

Code: Select all

;; Commands
;; RT turn right n degrees
;; LT turn left n degrees
;; FD move forward n units
;; BK move backward n units (not implimented yet, it is pointless)
;; UP raise pen, don't draw
;; DN lower pen, ready to draw
;; MV x y jump to position (draw line if DN)
;; LK n look (rotate) to absolute angle
;; FM free memory associated with the stored lines

(defstruct turtle (x 0) (y 0) (direction 0) (tail-down t)
	          (color "black")(lines nil))

(defparameter *turt* (make-turtle))
(print "turtle defined")

(defun deg-cos (degrees)
  (cos (* degrees 0.01745)))

(defun deg-sin (degrees)
  (sin (* degrees 0.01745)))

(defun lt (dir)
  (setf (turtle-direction *turt*) (- (turtle-direction *turt*) dir))) 

(defun rt (dir)
  (setf (turtle-direction *turt*) (+ (turtle-direction *turt*) dir))) 


(defun add-line (line)
  (setf (turtle-lines *turt*)
	(cons line (turtle-lines *turt*))))

(defun fd (units)
  (let ((old-x (turtle-x *turt*))
	(old-y (turtle-y *turt*)))
    (setf (turtle-x *turt*) (+ (turtle-x *turt*) 
			       (* (deg-cos (turtle-direction *turt*)) units))
	  (turtle-y *turt*) (+ (turtle-y *turt*) 
			       (* (deg-sin (turtle-direction *turt*)) units)))
    
    
	  (add-line `(,old-x ,old-y ,(turtle-x *turt*) ,(turtle-y *turt*)
			     ,(turtle-color *turt*)))))

(print "finish fd function")

(defun lk (dir)
  (setf (turtle-direction *turt*) dir)) 

(defun up ()
  (setf (turtle-tail-down *turt*) nil))

(defun dn ()
  (setf (turtle-tail-down *turt*) t))

(defun mv (x y) 
  (setf (turtle-x *turt*) x 
	(turtle-y *turt*) y))

(defun color (color-str)
  (setf (turtle-color *turt*) color-str))

(defun fm ()
  (setf (turtle-lines *turt*) '()))

Re: Language agnostic graphics (Project in CL + LTK)

Posted: Thu Oct 17, 2013 9:04 am

by edgar-rft

Since two days I'm trying to find a way how to keep the REPL working while the canvas window is open. There is a :SERVE-EVENT keyword that works with WITH-LTK and MAINLOOP, but no matter what I try, LTK throws errors at me. I've already asked on the ltk-user list, but no response yet.

See news.gmane.lisp.ltk.user for the full text (16 Oct 2013 18:26 - edgar - How is ":serve-event t" meant to be used?)

What I would like to have is a function that opens the canvas but then keeps the Lisp REPL alive, where I can type stuff while at the same time I can watch the lines drawn on the canvas:

Code: Select all

LTK-CANVAS> (fd 100)
LTK-CANVAS> (rt 90)

This would also answer the question for control constructs, because then you can just use normal Common Lisp control constructs to control the turtle commands. For example, drawing a triangle:

Code: Select all

LTK-CANVAS> (dotimes (n 3)
              (fd 100)
              (rt 60))

Unfortunately I've still found no working solution yet, but I'm far away from giving up...

- edgar

Re: Language agnostic graphics (Project in CL + LTK)

Posted: Thu Oct 17, 2013 10:59 pm

by Pixel_Outlaw

While you work on the LOGO part I'm trying to figure out how to simply pipe commands

I was given a small snippet of code to test in #Lisp on freenode but it seems that even after piping lines to the program it exists before the (princ) line is evaluated...

Code: Select all

#!/usr/bin/sbcl --script
 
(defun enumerate-lines ()
  (loop
     for line = (read-line)
     for n = 0 then (1+ n)
     while line do (format t "~a ~a~%" n line)))
 
(enumerate-lines)
(princ "is this working now")

Here is a file you can pipe out to it: (be sure to chmod +x the script first)
cat filename | ./test-script.lisp

http://pastebin.com/KNTZ0QQr

Re: Language agnostic graphics (Project in CL + LTK)

Posted: Sat Oct 19, 2013 2:53 am

by Goheeca

Try to flush an output buffer -- sorry it doesn't work. There are few problems with closing standard i/o programmatically as well as from the outer world obviously.

Re: Language agnostic graphics (Project in CL + LTK)

Posted: Sat Oct 19, 2013 12:00 pm

by Pixel_Outlaw

Ouch, that kind of undermines the whole project...
*IF* I understand you correctly.