0017-Picture-Editor.st

'From Smalltalk 5.5k XM November 24 on 22 November 1980 at 2:57:08 am.'

"BitRect" 
Class new title: 'BitRect'
	subclassof: Rectangle
	fields: 'title  "<String> title of picture"
		stripheight  "<Integer> scan lines in a buffer (private)"
		data  "<Vector> of Strings.  Saves the bits in the Rectangle"'
	declare: 'defaultpic ';
	asFollows 

BitRect is a Rectangle that remembers the bits within it.
To create and edit one, say:
		BitRect new fromuser edit.
This installs a BitRectEditor in the scheduler and starts it up.
The editor is explained in BitRectEditor.

Initialization 
classInit
	["the default picture is a gray rectangle"
	defaultpic ← BitRect new filin: 'defaultpic']
default [⇑defaultpic recopy]
fromuser
	[self title: 'BitRect' in: Rectangle new fromuser.
	self saveScreenBits]
origin: origin corner: corner title: title stripheight: stripheight data: data
title: title in: rect | nStrips i strips
	[origin←rect origin.  corner←rect corner.
	"the strip height is chosen so that each bitstring is about 2048 bytes"
	stripheight←1023/((self extent x + 15)/16).
	nStrips←(self extent y+stripheight-1)/stripheight.
	data←Vector new: nStrips.
	strips←self strips.
	for⦂ i to: nStrips do⦂
		[data◦i←String new: (strips◦i) bitStringLength]]

Access to parts 
data [⇑data]
title [⇑title]

Rectangle Protocol 
= x [⇑self≡x]
bitsOntoStream: strm | bits
	[for⦂ bits from: data do⦂ [strm append: bits]]
corner←x [self growby: x-corner]
extent←x [self growby: x-self extent]
growby: change | old
	[old←BitRect new origin: origin corner: corner title: title
		stripheight: stripheight data: data.
	self title: title in: (origin rect: corner+change).
	self copyBitsFrom: old]
growto: x [self growby: x-corner]
hash [user croak] primitive: 46
height←h [self growby: 0⌾(h-self extent y)]
printon: strm
	[strm append: 'a BitRect']
width←w [self growby: (w-self extent x)⌾0]

Editing 
copyBitsFrom: other
		| clippedStrip i j myStrips otherStrips myStrip otherStrip
	["copy all bits from other that are within my area"
	myStrips←self strips.  otherStrips←other strips.
	for⦂ i to: myStrips length do⦂
		[for⦂ j to: otherStrips length do⦂
			[myStrip←myStrips◦i.  otherStrip←otherStrips◦j.
			clippedStrip←myStrip intersect: otherStrip.
			clippedStrip empty⇒[]
			BitBlt init function←0;
				destbase←data◦i;
				destraster←myStrip width+15/16;
				dest←clippedStrip origin-myStrip origin;
				extent←clippedStrip extent;
				sourcebase←other data◦j;
				sourceraster←otherStrip width+15/16;
				source←clippedStrip origin-otherStrip origin;
				checksandcall]]]
edit | a
	[user leaveTop.
	a←BitRectEditor new picture: self.
	a takeCursor; enter.
	user restartup: a]

Showing 
saveScreenBits | strips i
	[strips←self strips.
	for⦂ i to: strips length do⦂
		[strips◦i bitsIntoString: data◦i mode: storing clippedBy: nil]]
show | strips i
	[strips←self strips.
	for⦂ i to: strips length do⦂
		[strips◦i bitsFromString: data◦i]]
strips   "return a vector of strips (Rectangles)"
		| nStrips strips stripOrigin stripExtent i
	[(nStrips←data length)=1⇒[⇑self inVector]
	strips←Vector new: nStrips.
	stripOrigin←origin.  stripExtent←self width⌾stripheight.
	for⦂ i to: nStrips-1 do⦂
		[strips◦i←Rectangle new origin: stripOrigin extent: stripExtent.
		stripOrigin←stripOrigin+(0⌾stripheight)].
	strips◦nStrips←Rectangle new origin: stripOrigin corner: corner.
	⇑strips]

Filin and filout 
filin: title | f i x y rect strips  "read bits from a file"
	[f←dp0 oldFile: (title concat: '.pic.').
	f readonly.
	f end⇒[f close. user notify: 'no data']

	x←f nextword.  y←f nextword.
	rect←Rectangle new origin: [origin is: Point⇒[origin] 0⌾0] extent: x⌾y.
	self title: title in: rect.
	stripheight≠f nextword⇒[user notify: 'strip heights dont match']
	strips ← self strips.
	for⦂ i to: strips length do⦂
		[f into: data◦i].
	f close]
filout | f i  "write bits on a file"
	[f ← dp0 file: (title concat: '.pic.').
	f nextword ← self extent x.
	f nextword ← self extent y.
	f nextword ← stripheight.
	for⦂ i from: data do⦂ [f append: i].
	f close]

Press 
length [⇑self bitStringLength]
presson: press in: r | w h hs scale w16 y [
	scale ← press scale.
	h ← self height.
	(hs  ← scale*h) > r height⇒ [
		"not enough room left on current page.
		assume for now that it will at least fit on an entire page"
		⇑self]

	w ← self width.
	w16 ← w + 15 | 16 "width to next word boundary".
	"with w, prints on viola but not on spruce.
	with w16, prints on spruce with garbage on end"
	press setp: 0⌾(y ← r corner y - hs);
		dots⦂ [
			press setcoding: 1 "bitmap" dots: w16 lines: h;
				setmode: 3 "to right and to bottom";
				setsizewidth: scale*w16 height: hs;
				setwindowwidth: w16 height: h;
				dotsfollow.
			self bitsOntoStream: press data].
	⇑y]

SystemOrganization classify: ↪BitRect under: 'Picture Editor'.
BitRect classInit

"BitRectEditor" 
Class new title: 'BitRectEditor'
	subclassof: Window
	fields: 'tool  "<BitRectTool> the current tool"
		picture  "<BitRect> the picture we are working on"
		dirty  "false if picture has not been modified"
		saveActionPic saveToolPic  "buffers for saving background" '
	declare: 'tools toolpic actionbuttons actionpic windowmenu ';
	asFollows 

BitRectEditor edits BitRects.
To create, say:
	BitRect new fromuser edit.
This installs a BitRectEditor in the scheduler and starts it up.
The editing tools are to the left of the picture.  (The first one looks like a doodle).  They are: draw-thin, erase, straightedge, gray-block, paintbrush, magnifier.  The actions for the tools are displayed above the picture.
See BitRectTool for explanations of the actions.

CAUTION: this ordering is arbitrary.  It is currently possible to set a new action for any of the tools, so that if you are not careful, the straightedge will start being a magnifier or whatever.  This should get fixed eventually.

tools = a RadioButtons. Each button owns a BitRectTool (the active one is held in tool).
actionbuttons = a Vector of RadioButtons.  The groups of buttons are: action, mode, pen width, gray, and grid.
toolpic = BitRect of icons for the tools (at side of picture).
actionpic = BitRect of icons for the parts of a tool (above picture)
windowmenu = menu for bluebug.

To edit a copy of the tool picture, say
	newpic←(BitRectEditor◦↪toolpic) recopy.
	newpic edit.
To install this copy as the menu picture, say
	BitRectEditor new toolpic: newpic recopy.
Do the analogous thing to edit the action picture.
Caution: the editor blows up if you edit the tool picture itself and not a copy.


Initialization 
actionpic: a [actionpic ← a]
classInit | t i
	[t ← Vector new: 6.
	for⦂ i to: t length do⦂ [t◦i ← BitRectTool new init].
	tools ← (RadioButtons new) vec: t at: 0⌾0 width: 20.
	windowmenu ← Menu new string: 'under
move
grow
close
filout
printbits'.
	actionpic←BitRect new filin: 'actionpic'.
	toolpic←BitRect new filin: 'toolpic'.
	self initmenu1]
initmenu1 | s z
	[s ← Vector new: 5. z ← 20.
	s◦1 ← (RadioButtons new) vec: ↪(setbrush paint block draw line blowup) at: 0⌾0 height: z. "action"
	s◦2 ← (RadioButtons new) vec: (black, dkgray, gray, ltgray, white) at: 0⌾0 height: z. "tone"
	s◦3 ← (RadioButtons new) vec: (0, 1, 2, 3) at: 0⌾0 height: z. "mode"
	s◦4 ← (RadioButtons new) vec: (1, 2, 4, 8) at: 0⌾0 height: z. "width"
	s◦5 ← (RadioButtons new) vec: (1, 2, 4, 8, 16, 32) at: 0⌾0 height: z. "grid"
	actionbuttons ← s.]
picture: picture
	[tool ← tools push: 1.
	self frame: (picture origin rect: picture corner)]
toolpic: a [toolpic ← a]

Window protocol 
bluebug | 
	[
	picture is: BitImage⇒ [ ⇑ picture fromrectangle: (picture rectangle)]
	windowmenu bug
	 =1 ⇒[self leave. ⇑exitflag ← false];  "under"
	=2 ⇒[self leave; newframe; enter];  "move"
	=3 ⇒[self grow  "grow"];
	=4 ⇒[self leave; erase.   "close"
		 user unschedule: self. ⇑false];
	=5 ⇒[self leave. picture filout. self enter];  "filout"
	=6 ⇒[self print]	"press file"]
enter | start pt b
	["Periodically check if the mouse is still in the frame.
		If not, stop showing the picture"
	super show.  self lostMouse⇒[⇑false]
	picture show.  dirty←false.  self lostMouse⇒[⇑false]
	for⦂ b from: actionbuttons do⦂ [b reset].
	"show action menu above the picture"
	start←frame origin-1.
	pt ← start-(0⌾actionpic extent y).
	actionpic moveto: pt.
	saveActionPic←actionpic bitsIntoString.
	self lostMouse⇒[⇑false]
	"last point I can return before having to restore bits under menus"
	actionpic show.
	pt ← actionbuttons◦1 moveto: pt. "action"
	pt ← actionbuttons◦3 moveto: pt. "mode"
	pt ← actionbuttons◦4 moveto: pt. "width"
	"show the next bank of action buttons"
	pt ← start-(0⌾(actionpic extent y+1/2)).
	pt ← actionbuttons◦2 moveto: pt.  "tone"
	pt ← actionbuttons◦5 moveto: pt.  "grid"
	tool brushpt: (pt ← pt+(7⌾7)).
	(tool brush) moveto: pt; show.
	"show the tool pic"
	pt ← start-(toolpic extent x⌾0).
	toolpic moveto: pt.
	saveToolPic ← toolpic bitsIntoString.
	toolpic show.
	tools moveto: pt;  setvalue: tool.
	tool frame: frame; showon: actionbuttons.]
fixframe: r
	[picture moveto: r origin.
	r corner←picture corner.
	⇑r]
grow | oldframe newframe pt r
	[self leave.
	newframe←picture origin rect: picture corner.
	CornerCursor showwhile⦂
		[pt←user mp+16.
		while⦂ user nobug do⦂
			[newframe corner←pt.  newframe comp.
			pt←user mp+16.  newframe comp].
		while⦂ user anybug do⦂
			[newframe corner←pt.  newframe comp.
			pt←user mp+16.  newframe comp]].
	"clear unused areas from old picture to background,
		and clear new picture areas to white"
	oldframe←picture inset: ¬2⌾¬2.  "¬2 is for erasing old border"
	for⦂ r from: (oldframe minus: newframe) do⦂ [r clear: background].
	for⦂ r from: (newframe minus: picture) do⦂ [r clear: white].
	picture title: picture title in: newframe; saveScreenBits.
	self frame: newframe; show; takeCursor; enter]
leave
	[[nil≡saveActionPic⇒[]
	 actionpic bitsFromString: saveActionPic.
	 saveActionPic ← nil.].
	 [nil≡ saveToolPic⇒[]
	 toolpic bitsFromString: saveToolPic.
	 saveToolPic←nil].
	[dirty⇒[picture saveScreenBits. dirty ← false]].
	frame border: 3 color: white]
lostMouse [⇑(frame has: user mp)≡false]
outside | pt
	[toolpic has: (pt←user mp)⇒
		[user redbug⇒
			[tool←tools bug: pt. tool frame: frame; showon: actionbuttons]]
	actionpic has: pt⇒
		[user redbug⇒
			[tool setfrom: actionbuttons]]
	⇑false]
redbug [dirty←true.  tool redbug]
showtitle   "The BitRectEditor have a menu where the title used to be"
title [⇑picture title]
tool [⇑ tool]
yellowbug
	[picture is: BitImage⇒ [ picture yellowbug] 
	]

SystemOrganization classify: ↪BitRectEditor under: 'Picture Editor'.
BitRectEditor classInit

"BitRectTool" 
Class new title: 'BitRectTool'
	subclassof: Object
	fields: 'action "<UniqueString> the current action"
		pencil  "<Turtle> used for draw or straight-edge"
		brush  "<BitRect> source for painting"
		mode  "<Integer> how brush combines with the destination"
		tone  "<Integer> a spatial half-tone color (4 bits by 4 bits)"
		grid  "<Integer> all mouse points are rounded to this"'
	declare: 'blowupScale graypens brushpt ';
	asFollows 

A BitRectTool paints on the screen.
A tool is a combination of action, mode, pen-width, gray, and grid.
	action is one of: make-brush, paint, block-of-gray, draw, straight-edge, magnify.
	mode is one of: store, or, xor, and.  (how tool is combined with picture)
	pen-width is 1, 2, 4, or 8.  (width of the pen)
	gray is one of: black, darkgray, gray, lightgray, white.
	grid is one of: 1, 2, 4, 8, 16, 32.   (minimum spacing of mouse points)
Menus for each part of a tool appear above the picture (in the same order).
Some actions do not use certain of the other parts of a tool.
(example: Block-of-gray does not use pen-width.)

brushpt = Point in the menu where brush is shown.
graypens = Vector of Strings of bits in pens.

Tool action 
block [self getRectangle color: tone mode: mode]
blowup | smallRect bigRectFrame
	[smallRect←self getRectangle.
	bigRectFrame ← Rectangle new origin: smallRect corner
		extent: 4⌾4 + (smallRect  extent*blowupScale).
	smallRect empty or⦂ bigRectFrame bitStringLength>4000⇒
		[pencil frame flash.  ⇑nil].
	[user screenrect has: bigRectFrame corner⇒[] 
		bigRectFrame moveto: smallRect origin-bigRectFrame extent.
		user screenrect has: bigRectFrame origin⇒[]
		"can't find a space for blown up image"	
		pencil frame flash.  ⇑nil].
	self blowup: smallRect to: bigRectFrame]
blowup: smallRect to: bigRectFrame
		| bigRect box pt i turt flag bits
	[bits ← bigRectFrame bitsIntoString.
	bigRect ← bigRectFrame inset: 2⌾2.
	smallRect blowup: bigRect origin by: blowupScale.
	turt←Turtle init.
	box ← 0⌾0 rect: (blowupScale-1)⌾(blowupScale-1).
	"keep editing in blowup mode until the user presses a button
		outside the big rect"
	while⦂ flag do⦂
		[bigRect has: (pt ← user mp)⇒
			[box moveto: bigRect origin + (i ← pt-bigRect origin|blowupScale).
			turt place: smallRect origin + (i/blowupScale).
			user redbug⇒[box color: black mode: storing. 
				turt black; go: 0]
			user yellowbug⇒[box color: white mode: storing. 
				turt white; go: 0]
			user bluebug⇒[bigRect flash]]		
		user anybug ⇒
			[(bigRect inset: ¬5⌾¬5) has: pt⇒[bigRect flash]
			"quit" flag←false]].
	bigRectFrame bitsFromString: bits]
brush [⇑brush]
brush: sourceRect   "use the bits in the BitRect sourceRect as a brush"
		| minpt maxpt pt offset
	["The inner painting loop should be fast - all the extra foliage below
		is to move tests outside of the inner loop"
	sourceRect moveto: brushpt; show.
	minpt←self frame origin.
	maxpt←self frame corner-sourceRect extent.
	offset←sourceRect extent/2.
	"If mode is storing or oring, use brush command, otherwise blt.
		Use the unclipped form of brushing  and grid=1 when possible"
	[mode<xoring and⦂ grid=1⇒
		[while⦂ user redbug do⦂
			[minpt≤(pt←user mp-offset) and⦂ pt≤maxpt⇒
				[sourceRect brush: pt mode: mode color: tone]
			sourceRect brush: pt mode: mode color: tone clippedBy: self frame]]
	 mode≥xoring and⦂ grid=1⇒
		[while⦂ user redbug do⦂
			[minpt≤(pt←user mp-offset) and⦂ pt≤maxpt⇒
				[sourceRect blt: pt mode: mode]
			sourceRect blt: pt mode: mode clippedBy: self frame]]
	 mode<xoring⇒   "grid is > 1"
		[while⦂ user redbug do⦂
			[minpt≤(pt←self mpOnGrid-offset) and⦂ pt≤maxpt⇒
				[sourceRect brush: pt mode: mode color: tone]
			sourceRect brush: pt mode: mode color: tone clippedBy: self frame]]
	 "grid is > 1 and mode≥xoring"
		while⦂ user redbug do⦂
			[minpt≤(pt←self mpOnGrid-offset) and⦂ pt≤maxpt⇒
				[sourceRect blt: pt mode: mode]
			sourceRect blt: pt mode: mode clippedBy: self frame]].
	]
draw
	[tone=white or⦂ tone=black⇒
		[pencil place: self mpOnGrid-pencil frame origin.
		grid=1⇒		"make drawing with grid 1 fast"
			[while⦂ user redbug do⦂
				[pencil goto: user mp-pencil frame origin]]
		while⦂ user redbug do⦂
			[pencil goto: self mpOnGrid-pencil frame origin]]
	self brush: graypens◦pencil width]
getRectangle | rect newrect start t   "rect must be in my frame"
	["the rect-newrect stuff is so that the complementing stays
		on for a while"
	start←self mpOnGrid.
	rect←newrect←(Rectangle new origin: start corner: start)
		intersect: self frame.
	"move the cursor slightly so that the user will notice the rectangle
		being complemented"
	user cursorloc←start+4.
	while⦂ user anybug do⦂
		[rect←newrect.
		rect comp.
		t←self mpOnGrid.
		newrect←(Rectangle new origin: (start min: t) corner: (start max: t))
			intersect: self frame.
		rect comp].
	⇑rect]
line | start end width
	[start←end←self mpOnGrid-pencil frame origin.
	width←pencil width.  pencil xor; width: 1.
	while⦂ user redbug do⦂
		[end←self mpOnGrid-pencil frame origin.
		pencil xor; place: start; goto: end; place: start; goto: end].
	[tone=white⇒[pencil white] pencil black].
	pencil width: width; place: start; goto: end]
mode
	[⇑ mode]
mpOnGrid   "return mouse point rounded to grid"
	[⇑user mp+(grid/2) | grid]
paint
	[self brush: brush]
redbug [self perform: action]
setbrush | rect
	[rect←self getRectangle.
	rect empty or⦂ 50⌾50<rect extent⇒[pencil frame flash].
	brush color: white mode: storing.
	brush title: 'brush' in: rect; saveScreenBits.
	brush moveto: brushpt; show.
	action ← ↪paint]
shade | p1 p2 a b t p r vs "down on redbug is black place.
	up on redbug is white place.  Subsequent redbugs
	paint a shade of gray depending on position between
	black and white (and beyond white to black again).
	Yellow or blue bug terminates."
	[until⦂ user redbug do⦂ [p1 ← user mp]. "black"
	until⦂ user nobug do⦂ [p2 ← user mp]. "white"

	vs ← ↪( ¬1  ¬1025  ¬1089  ¬585  ¬4681  ¬6731  ¬22058  ¬27031   ¬26986  ¬31191  ¬32108   5160  5128  8321  1025 01 0).
	r ← 0⌾0 rect: 10⌾10.
	b←(p1-p2). b ← b x asFloat ⌾ b y asFloat.
	a ← b x * b x + (b y * b y) /16.0.
	until⦂ (user yellowbug or⦂ user bluebug) do⦂
	[user redbug ⇒[p←user mp.
		t ← b* (p-p2).
		t ← (t x + t y /a) asInteger abs min: 16.
		brush brush: p mode: mode color: vs◦(17-t)]
	]
	]

tone
	[⇑ tone]

Tool selection 
brushpt: pt  "set the point at which the current brush will be shown"
	[brushpt←pt]
frame [⇑pencil frame]
frame: f [pencil frame: f]
setfrom: butvec | pt
	[butvec◦1 has: (pt ← user mp) ⇒
		[action ← butvec◦1 bug: pt]
	butvec◦2 has: pt ⇒[tone ← butvec◦2 bug: pt.
		tone=white ⇒[pencil white] pencil black]
	butvec◦3 has: pt ⇒[mode ← butvec◦3 bug: pt]
	butvec◦4 has: pt ⇒[pencil width: (butvec◦4 bug: pt)]
	butvec◦5 has: pt ⇒[grid ← butvec◦5 bug: pt]
	]
showon: butvec
	[butvec◦1 setvalue: action.
	butvec◦2 setvalue: tone.
	butvec◦3 setvalue: mode.
	butvec◦4 setvalue: pencil width.
	butvec◦5 setvalue: grid]

Class initialization 
classInit | rect saveBits t i
	[blowupScale←4.
	"make a vector of gray pens"
	rect ← 0⌾0 rect: 9⌾9.
	saveBits←rect bitsIntoString.
	t ← Turtle init.
	graypens ← Vector new: 8.
	for⦂ i to: 8 do⦂
		[t width: i.
		rect clear: white. 
		t place: 4⌾4; go: 0. 
		graypens◦i ← BitRect new title: 'graypen' in: rect.
		(graypens◦i) saveScreenBits].
	rect bitsFromString: saveBits]
init
	[(pencil ← Turtle new) init; black; width: 2.
	(brush ← BitRect new) title: 'brush' in: (0⌾0 rect: 16⌾16).
	tone ← black. mode ← 0. grid ← 1. action ← ↪draw]

SystemOrganization classify: ↪BitRectTool under: 'Picture Editor'.
BitRectTool classInit

"RadioButtons" 
Class new title: 'RadioButtons'
	subclassof: Object
	fields: 'vec  "<Vector> values corresponding to the buttons"
		cur  "<Integer> button currently selected"
		rect  "<Rectangle> contains all the buttons"
		size  "<Integer> width or height of a button"'
	declare: '';
	asFollows 

A RadioButtons is a row or column of square regions ("buttons") on the display screen.  There is always exactly one button pushed.  (RadioButtons is a model of the station selection buttons on a car radio.)  The pushed button has a black box around it.  Each button has a value associated with it, which is returned when the button is pressed.  RadioButtons will not destroy a menu picture (BitRect) displayed in its area, but the RadioButtons has no knowledge of the picture.


Pushing a Button 
bug: pt | r a
	[r ← (pt - rect origin - (1⌾1)) / size.
	a ← r x + r y + 1.
	⇑self push: a]
push: a
	[self release: cur thenPush: a.
	⇑vec◦(cur ← a)]
setvalue: v | i
	["if value has been lost, set self to 1"
	i←(vec find: v) max: 1.
	self push: i.  ⇑i]

Init and State 
has: pt [⇑rect has: pt]
moveto: pt
	[rect moveto: pt.
	cur ← 0.
	⇑rect corner x ⌾ rect origin y]
reset [cur←0]
value [⇑vec◦cur]
vec [⇑vec]
vec: vec at: r height: size
	[rect ← r rect: r+ ((vec length ⌾ 1)*size).
	cur ← 0]
vec: vec at: r width: size
	[rect ← r rect: r+ ((1 ⌾ vec length)*size).
	cur ← 0]

Private 
release: a thenPush: b | boxer offset
	[a=b⇒[]
	offset ← [size=rect extent y⇒[size⌾0] 0⌾size].
	[a≠0⇒[boxer ← Rectangle new origin: (offset*(a-1)+rect origin+1)
				extent: size⌾size-1.  boxer comp.  (boxer inset: 1⌾1) comp]].
	b≠0⇒[boxer ← Rectangle new origin: (offset*(b-1)+rect origin+1)
				extent: size⌾size-1.  boxer comp.  (boxer inset: 1⌾1) comp]]

SystemOrganization classify: ↪RadioButtons under: 'Picture Editor'.