Paint plus

The following script is an improvement of the paint program seen in the last post.

In order to use it, you can:

paint none [] ; brings up empty canvas
paint load %logo.png [] ; brings up the logo.png as the canvas
paint load %logo.png [[pen 0.0.0 line-width 2 fill-pen none box 147x90 191x117]] ; applies the draw to the logo

Here is the source:

Title: "Paint "
Date: 22-May-2001/17:15:51-7:00
Version: 1.0.0
File: %paintplus.r
Author: "Frank Sievertsen"
Purpose: "The world's smallest paint program."
Comment: {
Modified by Graham to load in a Rebol image, and a block containing draw dialected commands.
Thanks to Anton for suggestion on how to do the free hand draw.
Supports the arrow command, free hand draw, line width, and text tools.
Can't yet load in draw dialect with text commands.
usage: paint image [image! none!] data [block!]
paint none [] ; brings up empty canvas
paint load %logo.png [] ; brings up the logo.png as the canvas
paint load %logo.png [[pen 0.0.0 line-width 2 fill-pen none box 147x90 191x117]] ; applies the draw to the logo
context [
color: fill-color: start: draw-image: draw-pos: tmp: file-name: fs: fn: fontatt: fontlist: none
line-width: 2
type: ‘box oldtype: ‘box
undos: [] redos: []
my-text: copy “Hello there”
select-text: does [
view/new/title center-face layout [across
attribute1cg: check label black “bold”
attribute2cg: check label black “italic”
attribute3cg: check label black “underline” return
attribute1rg: radio of ‘fontstyle l: label black “Sans Serif”
attribute2rg: radio of ‘fontstyle label black “Serif”
attribute3rg: radio of ‘fontstyle label black “Fixed”
text “Size” font [] fontsz: field “20″ 40 [if error? try [fs: to-integer face/text] [face/text: 14 show fontsz]] return
deftextarea: area 400×100 return
btn “OK” [my-text: copy deftextarea/text unview
if error? try [fs: to-integer fontsz/text] [fs: 14]
fontatt: copy []
fn: copy “Sans Serif”
if attribute1cg/data [append fontatt [bold]]
if attribute2cg/data [append fontatt [italic]]
if attribute3cg/data [append fontatt [underline]]
fn: copy case [
attribute1rg/data [“Sans Serif”]
attribute2rg/data [“Serif”]
attribute3rg/data [“Fixed”]
true [“Sans Serif”]
append fontlist make face/font compose/deep [style: [(fontatt)] size: (fs) name: (fn)]
] pad 300 btn “Cancel” [unview]
] “Text Requester”
draw: func [offset /local tmp bl] [
bl: copy []
all [
either all [oldtype = type type = ‘free-hand] [
oldtype: type
repend bl [start offset]
] [true]
either all [oldtype = ‘arrow type <> ‘arrow] [append bl [arrow 0×0] true] [true]
append bl compose [pen (color/color) line-width (line-width) fill-pen (fill-color/color)]
either type = ‘text [
append bl compose [font (last fontlist) text (my-text) (offset)]
] [true]
switch/default type [
arrow [append bl [arrow 1×2 line]]
free-hand [append bl [line]]
] [append bl type]
append bl start
either type = ‘circle [
append bl reduce [tmp: offset - start
to-integer square-root add tmp/x ** 2 tmp/y ** 2
] [append bl offset]
if type = ‘arrow [
append bl [ arrow 0×0 ]
redo-draw: does [
append/only undos draw-pos
draw-pos: insert draw-pos last redos
remove back tail redos
show draw-image
undo-draw: does [
append/only redos copy last undos
draw-pos: clear last undos
remove back tail undos
show draw-image
set ‘paint func [
image-data [image! none!] {load a REBOL image}
redos-data [block!] {read in draw dialect commands}
/local ln data
] [
undos: copy []
redos: copy []
fontlist: copy []
type: ‘box
if not empty? redos-data [redos: copy/deep redos-data ]
if none? image-data [
image-data: to-image layout [ box 300×300 ]
view center-face lay: layout compose/deep [
backdrop effect compose [gradient 1×1 (sky) (water)]
draw-image: image (image-data) effect [draw []]
feel [engage: func [face action event] [
if all [type start] [
if find [over away] action [
if type <> ‘free-hand [clear draw-pos]
append draw-pos draw event/offset
if type = ‘free-hand [start: event/offset]
show face
if action = ‘up [
append/only undos draw-pos
draw-pos: tail draw-pos
start: none
oldtype: type
if all [type action = ‘down] [start: event/offset ]
do [if error? try [
draw-pos: draw-image/effect/draw
while [not empty? redos] [redo-draw]
] [alert “Error in image data - discarded” ]
style text text [
tmp: first back find face/parent-face/pane face
tmp/feel/engage tmp ‘down none
tmp/feel/engage tmp ‘up none
label “Tool:” return
radio [type: ‘line] text “Line” font []
mark: at
radio [type: ‘free-hand] text “Free” font []
radio true [type: ‘box] on text “Box” font []
radio [type: ‘circle] text “Circle” font []
radio [type: ‘arrow] text “Arrow” font []
radio [type: ‘text select-text] text “Text” font []
button “Undo” [if not empty? undos [
button “Clear” [
while [not empty? undos] [undo-draw]
oldtype: none
] return
button “Redo” [if not empty? redos [
]] return
button “Save” [
if r: request-file [
save/all r/1 undos
button “Print” [save/png %picture.png to-image draw-image
write %picture.html {<html>^/<body>^/<IMG src=”picture.png”>^/</body>^/</html>}
browse %picture.html
button “Dump” [print “undos” probe undos ]
at mark
style color-box box 15×15 [
oldtype: none
face/color: either face/color [request-color/color face/color] [request-color]
; face/color: request-color
            ] ibevel
color: color-box 0.0.0 text “Pen”
fill-color: color-box text “Fill-pen”
widthfld: field “2″ 20 [oldtype: none if error? try [line-width: to-integer face/text] [face/text: line-width: 2 show face]] label “Width”

Tags: ,

Print This Post Print This Post
1 Star2 Stars3 Stars4 Stars5 Stars (No Ratings Yet)
Loading ... Loading ...

Leave a Reply

You must be logged in to post a comment.