'From Squeak3.2 of 15 January 2002 [latest update: #4881] on 18 February 2003 at 11:07:41 pm'!
"Change Set:		telnet
Date:			16 October 2002
Author:			Ian Piumarta

This is a local and remote login client for Squeak comprising a protocol stack abstraction, endpoints for network (socket) and subprocess (pseudo tty) communication, a DFSA compiler (for taking the pain out of building stateful protocols), a partial-but-sufficient implementation of the RFC 854 telnet protocol, a glass teletype morph, an essentially complete VT102 terminal emulator (it passes the VT100/102 validation suite, except for wide and double-height characters and application keypad mode [trivial to implement, but I haven't got a keypad to test it with... ;-]) and the vast majority of an xterm emulator.  It comes with a class called PseudoTTY that implements the image side of Unix98 pseudo ttys (allowing the emulator to be connected to a subprocess that in turn believes itself to be connected to a real terminal -- can you say ``login shell''? ;-).  It's also turned into something of a `clickable' application: to fire it up, evaluate

	TeletypeWindow open

in a Workspace (or stick it in your `common expressions' menu) and then click on the window menu icon to start a shell or telnet session.

The terminal emulator now comes with its own font, a *real* TTY font that is infinitely more readable than Atlanta (and which has underscores and all the special graphics/line-drawing characters in all the right places).  It also supports colour correctly: adventurous GNU/Linux users might even like to try running `kbdconfig' in it (and comparing the result to what they see in a real xterm... <grin>!! ;-).  The only significant thing left to do is selection handling, copy and paste.

The telnet protocol has been tested with the GNU/Linux, Digital Unix (OSF/1) and Solaris telnet servers.  It requires only the standard Socket support to work and so should be FULLY FUNCTIONAL on Mac and Windows (assuming they implement the SO_OOBINLINE option in Socket>>setOption:value:).

The shell has been tested with bash and ash (the closest thing I have to a SysV shell) on GNU/Linux and Solaris (but there's no reason why it shouldn't work on any OS that supports Unix98 [aka XPG5 aka SUSv2] style PTYs).  It requires both AsynchFile and PseudoTTY plugins to work.  This means that the shell only works on Unix for the moment, until somebody gets round to porting the PseudoTTYPlugin to Windows and (ha ha) Mac.

Comments, suggestions and bug reports are welcome: ian.piumarta@inria.fr

Enjoy!!

(This changeset was supported by a generous quantity of Jaques Vabre coffee, thoroughly antisocial levels of Sergent Garcia's ``Un poquito quema'o'' and way too many Chesterfield Lights.  �Si no sanas hoy, sanar�s ma�ana!!)"!

OrderedCollection subclass: #LayeredProtocol
	instanceVariableNames: 'properties '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Communications-Abstract'!

!LayeredProtocol commentStamp: '<historical>' prior: 0!
I am a complete protocol implemented as a stack of subprotocols.  One end of the stack (the bottom or `tail') is usually an endpoint communicating with some remote host or process.  The other end (the top or `head') is either the point of communication for my client (which reads and writes only application-oriented data) or even the client itself.

I am created by sending my class the message #on: aSubProtocol.  You can then send me #push: aProtocol as many times as you like, to push aProtocol onto the head of my protocol stack.  When the stack is complete you must send me #install which tells me to finish creating the internal connections between each subprotocol in the stack.  Finally you send me #run which tells the entire protocol stack to start.!

LayeredProtocol class
	instanceVariableNames: ''!
Object subclass: #ProtocolLayer
	instanceVariableNames: 'session up down '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Communications-Abstract'!

!ProtocolLayer commentStamp: '<historical>' prior: 0!
I am a single layer in a LayeredProtocol stack.  I pass information up and down the stack, possibly transforming it in the process.

Structure:
	down		(ProtocolLayer) My low protocol, one element closer to the "remote connection" end of the stack.
	up			(ProtocolLayer) My high protocol, one element closer to the user interface or other "local client".
	session		(LayeredProtocol) The entire collection of ProtocolLayers of which I am one.
!

ProtocolLayer subclass: #ProtocolAdaptor
	instanceVariableNames: 'upBlock downBlock flushBlock noteBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Communications-Protocols'!

!ProtocolAdaptor commentStamp: '<historical>' prior: 0!
I am a pluggable ProtocolLayer.  You can insert me anywhere in a LayeredProtocol stack.

Communication between protocol stack layers is accomplished using the following messages:

	upcall: datum					-- receive data from the protocol below me in the stack
	downcall: datum					-- receive data from the protocol above me
	flush							-- the protocol below me might become idle for a while
	note: aSymbol with: anObject	-- I am being informed that something "global" has happened

By default I am completely transparent.  In other words I react to the above messages as follows:

	upcall: datum					-- I pass datum on to the protocol above me
	downcall: dataum				-- I pass datum on to the protocol below me
	flush							-- I pass the message to the protocol above me
	note: sym with: obj				-- is ignored entirely

Any or all of these default reactions can be changed by installing blocks which I will execute in response to the above messages.  You install such blocks by sending me the following messages:

	upBlock: unaryBlock			-- evaluated on #up: passing datum as argument
	downBlock: unaryBlock			-- evaluated on #down: passing datum as argument
	flushBlock: aBlock				-- evaulated on #flush with no arguments
	noteBlock: binaryBlock			-- evaulated on #note:with: passing aSym and anObj as arguments

By now you've probably guess that my default behaviour is simply to install the following blocks when I am created:

	upBlock: [:datum | up upcall: datum]
	downBlock: [:datum | down downcall: datum]
	flushBlock: []
	noteBlock: [:aSymbol :anObject | ]

My class knows how to instantiate particular kinds of default behaviour in me, including:

	pass							-- the default (transparency)
	trace							-- prints each datum on the Transcript as it whizzes by
	reflect							-- bounces downward data back up the stack and vice-versa

Here's one example, possibly the shortest known means to create an "echo" server:

	(NetworkEndpoint socket: anAcceptedSocket) asProtocolStack
		push: ProtocolAdaptor reflect;
		install;
		run!

ProtocolAdaptor class
	instanceVariableNames: ''!
ProtocolLayer subclass: #ProtocolEndpoint
	instanceVariableNames: 'serverProcess '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Communications-Endpoints'!

!ProtocolEndpoint commentStamp: '<historical>' prior: 0!
I am an abstract endpoint for communication within a LayeredProtocol stack.  (I therefore expect to be the lowest element in that stack.)  I implement a server which waits for incoming data and then passes it up the stack for processing by higher protocol layers.  The actual reading of data from the remote entity must be implemented by my concrete subclasses.!

ProtocolEndpoint subclass: #NetworkEndpoint
	instanceVariableNames: 'socket '
	classVariableNames: 'InstanceList '
	poolDictionaries: ''
	category: 'Communications-Endpoints'!

!NetworkEndpoint commentStamp: '<historical>' prior: 0!
I am an endpoint for network communication.  I am also a ProtocolLayer and I therefore expect to be inserted as the lowest element in a LayeredProtocol stack.

Structure:

	socket			(Socket)	-- the socket on which I communicate.
!

NetworkEndpoint class
	instanceVariableNames: ''!
ProtocolEndpoint subclass: #ProcessEndpoint
	instanceVariableNames: 'pty command arguments '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Communications-Endpoints'!

!ProcessEndpoint commentStamp: '<historical>' prior: 0!
I am an endpoint for communication with another process.  I am also a ProtocolLayer and I therefore expect to be inserted as the lowest element in a LayeredProtocol stack.

Well, that's the official story anyway.  In fact I am happy to communicate with anything that talks through an AsyncFile.  It just so happens that one kind of AsyncFile is PsuedoTTY which can be connected to the stdin, stdout and stderr of a remote process.

Structure:

	pty			(PseudoTTY)	-- the asynchronous file with which I communicate.
!

ProcessEndpoint class
	instanceVariableNames: ''!
IdentityDictionary subclass: #ProtocolState
	instanceVariableNames: 'name default '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Communications-Abstract'!

!ProtocolState commentStamp: '<historical>' prior: 0!
I am a single state within a cyclic graph of states.  My values are edges leading to another state in the graph.  If the edge has an action associated with it then I perform the method of that name in my client object, passing the object which stepped me as argument, before following the edge.

Structure:
 name		Symbol				-- my state's name
 keys		Object				-- the input tokens that cause me to step
 values		#(Symbol1 Symbol2)	-- an edge: the next state and a client action selector
 default		#(Symbol1 Symbol2)	-- the edge I follow if no key matches the stepping object

I am intended to be inserted somewhere in the middle of a LayeredProtocol stack.!

ProtocolState class
	instanceVariableNames: ''!
Object subclass: #ProtocolStateTransition
	instanceVariableNames: 'state action '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Communications-Abstract'!

!ProtocolStateTransition commentStamp: '<historical>' prior: 0!
I am a transition to a new ProtocolState.  While making the transition I can perform some action association with the change from the old to the new state.!

ProtocolStateTransition class
	instanceVariableNames: ''!
Socket subclass: #SafeSocket
	instanceVariableNames: 'hostName '
	classVariableNames: 'InstanceList '
	poolDictionaries: ''
	category: 'Communications-Endpoints'!

!SafeSocket commentStamp: '<historical>' prior: 0!
I am a Socket that knows about the dangers of remaining open across snapshot.!

SafeSocket class
	instanceVariableNames: ''!
Morph subclass: #SimpleTextMorph
	instanceVariableNames: 'font fgMap bgMap pitch rv lineState cursorColour '
	classVariableNames: 'Background Background2 DefaultStyle Foreground Foreground2 '
	poolDictionaries: ''
	category: 'Communications-Terminal Emulation'!

!SimpleTextMorph commentStamp: '<historical>' prior: 0!
I display a string with optional foreground, background and emphasis changes.  I shouldn't really exist but StringMorph doesn't know how to change colour or emphasis in mid-run and cannot affect its background colour at all.  On the other hand, TextMorph does way too much and wants to take over keyboard and mouse input and a whole bunch of other useless stuff such as line wrapping.  I could have used Text as my underlying representation and reused TextMorph's scanner except that it works on paragraphs (not linear text) and can't change background colour anyway.  Ho hum.  Short of installing a whole bunch of new rendering methods in the various canvases to plass explicit background colour information, I guess I just have to do everything myself.  C'est la vie, I suppose.

	SimpleTextMorph example

Structure:
	font		StrikeFont		-- the font I render with (this had better be monospaced!!)
	pitch		SmallInteger	-- the width of a character in font
	string		String			-- my contents
	fgRuns		Array			-- foreground changes (should be RunArray)
	bgRuns		Array			-- background changes (ditto)
	emRuns		Array			-- emphasis changes (ditto)!

SimpleTextMorph class
	instanceVariableNames: ''!
Object subclass: #SimpleTextState
	instanceVariableNames: 'string stringSize fgRuns bgRuns emRuns cursorCol changed selection lastCol '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Communications-Terminal Emulation'!
SimpleTextState class
	instanceVariableNames: ''!
ProtocolLayer subclass: #StatefulProtocol
	instanceVariableNames: 'currentState client '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Communications-Abstract'!

!StatefulProtocol commentStamp: '<historical>' prior: 0!
I am a ProtocolLayer.  I implement my protocol as a state machine, transitioning from one state to another according to patterns that I recognise in the data flowing through me.!

StatefulProtocol class
	instanceVariableNames: ''!
IdentityDictionary subclass: #StatefulProtocolDescription
	instanceVariableNames: 'initialState '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Communications-Abstract'!

!StatefulProtocolDescription commentStamp: '<historical>' prior: 0!
I am a collection of ProtocolStates constituting a transition graph for a StatefulProtocol.  See my class side for some examples of how I construct state machine descriptions for you.

Note that before I can be used to drive a StatefulProtocol you *must* send me #compile.  I will answer the initial ProtocolState in the compiled transition graph.  (I will also complain if your protocol is broken. ;-)  You subsequently pass this ProtocolState as the argument to StatefulProtocol class>>initialState: in order to instantiate a new StatefulProtocol.

Structure:
 initialState		Symbol	-- the name of the initial (root) node in my transition graph!

StatefulProtocolDescription class
	instanceVariableNames: ''!
StatefulProtocol subclass: #StatefulProtocolTester
	instanceVariableNames: 'prefix '
	classVariableNames: 'States '
	poolDictionaries: ''
	category: 'Communications-Abstract'!

!StatefulProtocolTester commentStamp: '<historical>' prior: 0!
I am a simple (but complete) state machine.  I recognise sequences of characters (with embedded numeric arguments for certain sequences) in strings.  I also print out what I'm doing on the Transcript so that you can see precisely how I work.

	StatefulProtocolTester test

Structure:
 prefix		SmallInteger	-- the numeric argument currently under contruction!

StatefulProtocolTester class
	instanceVariableNames: ''!
StatefulProtocolTester subclass: #StatefulProtocolTester2
	instanceVariableNames: 'e x xy xyz '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Communications-Abstract'!

!StatefulProtocolTester2 commentStamp: '<historical>' prior: 0!
I am just like StatefulProtocolTester except that I measure the throughput of the protocol as number of state transitions per second.

	StatefulProtocolTester2 test!

StatefulProtocolTester2 class
	instanceVariableNames: ''!
RectangleMorph subclass: #TeletypeMorph
	instanceVariableNames: 'inset font pitch skip rows cols lines savedLines savedLineLimit displayStart topLine bottomLine down x y fg bg em rv ec tabs useScrollbar scroll scrollFlop scrollRight scrollOn autoWrap reverseWrap autoLinefeed autoCR relativeOrigin insertMode showCursor session systemWindow running autoFlush smoothScroll steps metaSendsEscape deleteIsDel altScreenSwitch altScreenActive altScreenColours reverseVideo hasFocus mousePosition selectionStart selectionEnd selectionActive selection trackingSelection mouseControlsSelection keyboardControlsSelection scrollOnInput scrollOnOutput allow132 characterClasses cursorColour '
	classVariableNames: 'CharClass KeyboardControlsSelection MouseControlsSelection SaveTerminalSize SavedLineLimit TextCursor '
	poolDictionaries: ''
	category: 'Communications-Terminal Emulation'!

!TeletypeMorph commentStamp: '<historical>' prior: 0!
I am a glass teletype.  I accept raw input from some source (which I display without interpretation) and generate raw characters for some sink.

I implement sufficient cursor addressing and character attributes to provide terminal emulators with the necessary support to implement ANSI (ISO 6429) colours and emphasis (with the exception of blinking) and the full range of VT220-style cursor-based screen editing.  However, I make no attempt to interpret ASCII control characters nor ANSI, DEC (or any other) escape sequences.  This, like all other `cooked' interpratation of special characters, is left entirely to my source and sink (which will normally be the same instance of some terminal emulator, immediately below me in a protocol stack).

I am designed to be the head of a protocol stack.  For this reason I expect my source to send me #upcall: aCharacter (I am the high protocol for some emulator) and I pass keyboard events down to my sink by sending it #downcall: aCharacter (the sink is my low protocol).  Anybody can send me #delete which I will propagate to all members of my protocol stack as a #windowClosed note.  (This will normally cause any connected endpoints at the tail end of the stack to be disconnected and destroyed.)

	TeletypeMorph new openInWorld
!

TeletypeMorph class
	instanceVariableNames: ''!
SystemWindow subclass: #TeletypeWindow
	instanceVariableNames: 'tty windowTitle iconTitle '
	classVariableNames: 'AutoClose SaveTelnetOptions SaveTerminalMainOptions SaveTerminalSize SaveTerminalVTOptions Shortcuts TerminalType '
	poolDictionaries: ''
	category: 'Communications-Terminal Emulation'!

!TeletypeWindow commentStamp: '<historical>' prior: 0!
I am a kind of SystemWindow intended specifically for hosting a TeletypeMorph.  I provide connection-oriented menus, persistent preferences and menu-based access to my TeletypeMorphs options.!

TeletypeWindow class
	instanceVariableNames: ''!
StatefulProtocol subclass: #TelnetProtocol
	instanceVariableNames: 'debug dumpNetData dumpTermData doNAWS cols rows '
	classVariableNames: 'AO AYT Break Commands DataMark Debug Do Dont DumpNetData DumpTermData EC EL Echo EnvironmentOption ForwardX GoAhead IAC IP Is Linemode Logout NAWS NewEnvironment Nop Options RemoteFlowControl SB SE Send Status Subnegotiation SuppressGoAhead SuppressLocalEcho TerminalSpeed TerminalType Will Wont XDisplayLocation '
	poolDictionaries: ''
	category: 'Communications-Protocols'!

!TelnetProtocol commentStamp: '<historical>' prior: 0!
I am a ProtocolLayer implementing the telnet (RFC 854) protocol.  I expect to be inserted into a LayeredProtocol stack in which the endpoint is connected to a remote telnet server.  When I receive #run from the protocol stack I will begin negotiation with the remove server.  If the negotiation is successful, the protocol above me in the stack (or the client of the entire stack) will see an interactive login session.!

TelnetProtocol class
	instanceVariableNames: 'States '!
StatefulProtocol subclass: #VT102Emulator
	instanceVariableNames: 'arguments window trace mode keypadMode cursorState charMap g0Map g1Map keyMap '
	classVariableNames: 'CharsGR CharsUK CharsUS '
	poolDictionaries: ''
	category: 'Communications-Terminal Emulation'!

!VT102Emulator commentStamp: '<historical>' prior: 0!
I emulate a VT102 terminal.  The VT102 is an enhanced VT100 with additional screen editing functions, especially useful for full-screen editors (like Emacs) running over slow connections.

I expect to be inserted somewhere in the middle of a protocol stack.  My low procotol (usually some kind of remote login protocol) sends me #upcall: aCharacter to display aCharacter.  I filter out control sequences (sending appropriate messages to my window (usually a TeletypeMorph) to effect cursor movement, character attribute manipulation, screen editing and so on) or simply pass printing characters up to my high protocol (usually the same TeletypeMorph as my window) verbatim for display.  I accept keyboard input from my high protocol (again usually my window) which I pass down to my low protocol with conversion from Squeak keycodes to ANSI or DEC escape sequences representing cursor and other special keys.

I'm a subclass of Protocol, which is a subclass of StateMachine, since terminal emulation is simply a matter of recognising particular patterns (`escape sequences') in a stream of characters (as is any kind of `protocol').

I recognise the escape sequences as defined in: "VT102 Video Terminal User Guide", 3rd edition, Digital Equipment Corporation, February 1982, part number EK-VT102-UG-003.  When in VT52 mode I also recognise the escape sequences defined in "DECscope User's Manual", 1st edition, Digital Equipment Corporation, April 1976, part number EK-VT5X-OP-001.  (If you don't own copies of these historic documents then Shame On You!! ;-)!

VT102Emulator class
	instanceVariableNames: 'States '!
VT102Emulator subclass: #XtermEmulator
	instanceVariableNames: 'savedBuffer '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Communications-Terminal Emulation'!

!XtermEmulator commentStamp: '<historical>' prior: 0!
I emulate a xterm terminal.  The xterm is a modern member of the DEC VT200 family with additional ANSI functions including support for ISO 6429 colour escape sequences.  I am particularly useful for full-screen programs that know how to use colour highlighting (such as Emacs version 21 and higher).

I inherit from VT102Emulator because I implement a proper superset of its capabilities.

See the class comments in my superclasses (VT102Emulator in particular) for further information on how to use me.!

XtermEmulator class
	instanceVariableNames: ''!

!BlockContext methodsFor: 'evaluating'!
value: arg1 value: arg2 value: arg3 value: arg4 value: arg5
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects other than three arguments or if the block is already being 
	executed. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: 
		(Array
			with: arg1
			with: arg2
			with: arg3
			with: arg4
			with: arg5)! !


!FormCanvas methodsFor: 'drawing-text'!
drawString: aString from: firstIndex to: lastIndex in: bounds font: fontOrNil color: c background: b
	| font portRect |
	port colorMap: nil.
	portRect _ port clipRect.
	port clipByX1: bounds left + origin x 
		y1: bounds top + origin y 
		x2: bounds right + origin x 
		y2: bounds bottom + origin y.
	font _ fontOrNil ifNil: [TextStyle defaultFont].
	port combinationRule: Form paint.
	font installOn: port
		foregroundColor: (self shadowColor ifNil:[c]) 
		backgroundColor: b.
	font displayString: aString asString on: port 
		from: firstIndex to: lastIndex at: (bounds topLeft + origin) kern: 0.
	port clipRect: portRect.! !


!LayeredProtocol methodsFor: 'initialize-release'!
initializeProperties

	properties _ IdentityDictionary new! !

!LayeredProtocol methodsFor: 'accessing'!
head
	"Answer the head of the stack."

	^self first! !

!LayeredProtocol methodsFor: 'accessing'!
pop
	"Remove the head of the stack."

	^self removeFirst! !

!LayeredProtocol methodsFor: 'accessing'!
propertyAt: aKey

	^properties at: aKey ifAbsent: []! !

!LayeredProtocol methodsFor: 'accessing'!
propertyAt: aKey ifAbsent: aBlock

	^properties at: aKey ifAbsent: aBlock! !

!LayeredProtocol methodsFor: 'accessing'!
propertyAt: aKey put: aValue

	^properties at: aKey put: aValue! !

!LayeredProtocol methodsFor: 'accessing'!
push: aProto
	"Push a new protocol onto the head of the stack."

	self addFirst: aProto! !

!LayeredProtocol methodsFor: 'accessing'!
tail
	"Answer the tail of the stack."

	^self last! !

!LayeredProtocol methodsFor: 'protocol'!
endpoint

	^self last! !

!LayeredProtocol methodsFor: 'protocol'!
install

	| prev |
	prev _ nil.
	self do: [:this |
		this session: self.
		prev isNil ifFalse: [this up: prev.  prev down: this].
		this install.
		prev _ this]! !

!LayeredProtocol methodsFor: 'protocol'!
isConnected

	^self endpoint isConnected! !

!LayeredProtocol methodsFor: 'protocol'!
note: aSymbol with: anObject
	"Inform my members that something has happened."

	self do: [:proto | proto note: aSymbol with: anObject]! !

!LayeredProtocol methodsFor: 'protocol'!
run

	self do: [:proto | proto run]! !

!LayeredProtocol methodsFor: 'private'!
addDown: proto

	^self addLast: proto! !

!LayeredProtocol methodsFor: 'private'!
addUp: proto

	^self addFirst: proto! !

!LayeredProtocol methodsFor: 'private'!
removeUp

	^self removeFirst! !


!LayeredProtocol class methodsFor: 'instance creation'!
new

	^super new initializeProperties! !

!LayeredProtocol class methodsFor: 'instance creation'!
on: proto

	^self new push: proto! !

!LayeredProtocol class methodsFor: 'examples'!
example
	"Send 42 down a stack and then reflect it back up."
	"LayeredProtocol example"

	(ProtocolAdaptor new reflect asProtocolStack
		push: ProtocolAdaptor new trace;
		push: ProtocolAdaptor new trace;
		push: (ProtocolAdaptor new trace
				upBlock: [:arg | Transcript cr; show: 'ping ' , arg printString]);
		install;
		run;
		first) downcall: 42! !

!LayeredProtocol class methodsFor: 'examples'!
example3
	"LayeredProtocol example3"
	"Glass teletype with local echo."

	^ProtocolAdaptor new localEcho asProtocolStack
		push:	TeletypeMorph new openInWorld;
		install;
		run! !


!ProtocolLayer methodsFor: 'accessing'!
down: protoLo

	down _ protoLo! !

!ProtocolLayer methodsFor: 'accessing'!
session

	^session! !

!ProtocolLayer methodsFor: 'accessing'!
session: aSession

	session _ aSession! !

!ProtocolLayer methodsFor: 'accessing'!
up: protoHi

	up _ protoHi! !

!ProtocolLayer methodsFor: 'testing'!
isConnected

	^false! !

!ProtocolLayer methodsFor: 'stack'!
asProtocolStack
	"Answer a new LayeredProtocol in which I am the lowest element."

	^LayeredProtocol on: self! !

!ProtocolLayer methodsFor: 'stack'!
downcall: anObject
	"Receive anObject from my high protocol.  The default behaviour is to pass it down unmodified to my low protocol (i.e., I am transparent)."

	down downcall: anObject! !

!ProtocolLayer methodsFor: 'stack'!
downcallAll: aCollection
	"Receive aCollection of data from my high protocol.  The default behaviour is to act as if each datum was received individually."

	aCollection do: [:elt | self downcall: elt]! !

!ProtocolLayer methodsFor: 'stack'!
flush
	"Inform my high protocol that we might be about to pause for a while."

	up flush! !

!ProtocolLayer methodsFor: 'stack'!
install
	"Perform any additional actions when creating the initial up/down connections between elements in the ProtocolStack."! !

!ProtocolLayer methodsFor: 'stack'!
passUp: anObject
	"Pass anObject up to my high protocol."

	up upcall: anObject! !

!ProtocolLayer methodsFor: 'stack'!
push: aProtocol
	"Push aProtocol on top of the receiver."

	^(LayeredProtocol on: self) push: aProtocol! !

!ProtocolLayer methodsFor: 'stack'!
run
	"Perform any additional actions when starting the protocol running (i.e., just before data transfer begins)."! !

!ProtocolLayer methodsFor: 'stack'!
upcall: anObject
	"Receive anObject from my low protocol.  Default is to pass it on to my high protocol unmodified (in other words, I am transparent)."

	up upcall: anObject! !

!ProtocolLayer methodsFor: 'stack'!
upcallAll: aCollection
	"Receive aCollection of data from my low protocol.  By default I act as if each datum had been received individually."

	aCollection do: [:b | self upcall: b]! !

!ProtocolLayer methodsFor: 'session'!
note: aSymbol with: anArgument
	"My session is informing me that something has happened.  By default I don't care about it."! !

!ProtocolLayer methodsFor: 'session'!
sessionNote: aSymbol
	"Tell my session that something has happened.  If I have no session then do nothing."

	session isNil ifFalse: [session note: aSymbol with: nil]! !

!ProtocolLayer methodsFor: 'session'!
sessionNote: aSymbol with: anArgument
	"Tell my session that something has happened.  If I have no session then do nothing."

	session isNil ifFalse: [session note: aSymbol with: anArgument]! !

!ProtocolLayer methodsFor: 'diagnostics'!
ttyCR

	self ttyMsg: String cr! !

!ProtocolLayer methodsFor: 'diagnostics'!
ttyMsg: aString

	aString withInternetLineEndings asByteArray do: [:b | up upcall: b].
	up flush! !

!ProtocolLayer methodsFor: 'diagnostics'!
ttyMsgCR: aString

	self ttyMsg: aString, String cr! !


!ProtocolAdaptor methodsFor: 'initialize-release'!
initialize

	upBlock _ [:arg | self notify: 'up ' , arg printString].
	downBlock _ [:arg | self notify: 'down ' , arg printString].
	flushBlock _ [].
	noteBlock _ [:s :a | ]! !

!ProtocolAdaptor methodsFor: 'canned protocols'!
localEcho
	"A reflect suitable for local echo on dumb ttys, when placed immediately below a TtyMorph, recognising a few of the ASCII control characters."

	| c |
	^self
		upBlock: [:arg | down downcall: arg];
		downBlock: [:arg | c _ arg bitAnd: 127.
			(c == 8) | (c == 127) ifTrue: [up bs; upcall: 32; bs]
				ifFalse: [(c == 10) | (c == 13) ifTrue: [up newline]
				ifFalse: [c >= 32 ifTrue: [up upcall: c]]].
			up flush.]! !

!ProtocolAdaptor methodsFor: 'canned protocols'!
pass

	^self
		upBlock: [:arg | up upcall: arg];
		downBlock: [:arg | down downcall: arg]! !

!ProtocolAdaptor methodsFor: 'canned protocols'!
reflect

	^self
		upBlock: [:arg | down downcall: arg];
		downBlock: [:arg | up upcall: arg; flush]! !

!ProtocolAdaptor methodsFor: 'canned protocols'!
trace

	^self
		upBlock: [:arg |
			Transcript cr; nextPutAll: 'up ' , arg printString; endEntry.
			up upcall: arg];
		downBlock: [:arg |
			Transcript cr; nextPutAll: 'down ' , arg printString; endEntry.
			down downcall: arg]! !

!ProtocolAdaptor methodsFor: 'accessing'!
downBlock: block

	downBlock _ block! !

!ProtocolAdaptor methodsFor: 'accessing'!
flushBlock: block

	flushBlock _ block! !

!ProtocolAdaptor methodsFor: 'accessing'!
noteBlock: block

	noteBlock _ block! !

!ProtocolAdaptor methodsFor: 'accessing'!
upBlock: block

	upBlock _ block! !

!ProtocolAdaptor methodsFor: 'protocol'!
downcall: arg

	downBlock value: arg! !

!ProtocolAdaptor methodsFor: 'protocol'!
flush

	flushBlock value! !

!ProtocolAdaptor methodsFor: 'protocol'!
note: aSymbol with: anObject

	noteBlock value: aSymbol value: anObject! !

!ProtocolAdaptor methodsFor: 'protocol'!
upcall: arg

	upBlock value: arg! !


!ProtocolAdaptor class methodsFor: 'instance creation'!
new

	^super new initialize! !

!ProtocolAdaptor class methodsFor: 'instance creation'!
upBlock: aBlock

	^self new upBlock: aBlock! !


!ProtocolEndpoint methodsFor: 'protocol'!
close
	"Terminate the connection to the remote entity."

	^self subclassResponsibility! !

!ProtocolEndpoint methodsFor: 'protocol'!
downcall: anObject
	"Receive anObject from my high protocol.  The default behaviour (in Protocol) is to pass it down to my low protocol.  ProtocolEndpoints however are at the bottom of the ProtocolStack and thus have no low protocol, so they have to treat this specially (e.g., by sending the data over the network or to another process)."

	^self subclassResponsibility! !

!ProtocolEndpoint methodsFor: 'protocol'!
isConnected
	"Answer whether the endpoint is still connected."

	^self subclassResponsibility! !

!ProtocolEndpoint methodsFor: 'protocol'!
name
	"Answer the name of the remote entity."

	^self subclassResponsibility! !

!ProtocolEndpoint methodsFor: 'protocol'!
note: aSymbol with: anObject

	super note: aSymbol with: anObject.
	aSymbol == #endpointClosed ifTrue: [^self terminateServer].
	aSymbol == #windowClosed ifTrue: [^self close].! !

!ProtocolEndpoint methodsFor: 'protocol'!
run
	"Spawn a background process running the serverLoop."

	super run.
	serverProcess _ [self serverLoop] forkAt: Processor userSchedulingPriority.! !

!ProtocolEndpoint methodsFor: 'server loop'!
getData
	"Answer a collection of data to be passed up the protocol stack, or nil if the endpoint has failed."

	^self subclassResponsibility! !

!ProtocolEndpoint methodsFor: 'server loop'!
serverLoop
	"I sit in a loop (usually in a background Process) waiting for data to arrive on my underlying connection then pass anything received up to my high protocol.  When #getData answers nil to inform me that my underlying connection has been destroyed I close down the entire endpoint, inform my session of the fact and then exit.  See also ProtocolEndpoint>>run."

	| buf |
"MessageTally spyOn: ["
	Transcript cr; show: self class name, ' server running'.
	[(buf _ self getData) notNil] whileTrue: [up upcallAll: buf].
	serverProcess _ nil.
	self sessionNote: #endpointClosed; close.
	Transcript cr; show: self class name, ' server terminated'.
"] toFileNamed: 'spy.out'"! !

!ProtocolEndpoint methodsFor: 'server loop'!
terminateServer
	"Terminate the serverLoop process.  This should never be called directly: use #close instead."

	serverProcess isNil
		ifFalse:
			[serverProcess terminate.
			 serverProcess _ nil.
			 self sessionNote: #disconnected.
			 Transcript cr; show: self class name, ' server terminated']! !


!NetworkEndpoint methodsFor: 'accessing'!
getData

	| buf count |
	Processor yield.
	buf _ ByteArray new: 1024.
	[socket dataAvailable
		ifTrue:
			[count _ socket receiveDataInto: buf.
			 ^buf copyFrom: 1 to: count]
		ifFalse:
			[up flush.
			 socket waitForDataUntil: (Socket deadlineSecs: 1)].
	 socket isConnected]
		whileTrue.
	^nil! !

!NetworkEndpoint methodsFor: 'accessing'!
isConnected

	^socket notNil and: [socket isConnected]! !

!NetworkEndpoint methodsFor: 'accessing'!
name
	"Answer the name of the peer."

	(socket isNil or: [socket isConnected not])
		ifTrue: [^'not connected'].
	^NetNameResolver stringFromAddress: socket remoteAddress! !

!NetworkEndpoint methodsFor: 'accessing'!
socket

	^socket! !

!NetworkEndpoint methodsFor: 'protocol stack'!
downcall: char

	socket isConnected
		ifTrue: [socket sendData: (ByteArray with: char)]
		ifFalse: [socket closeAndDestroy]! !

!NetworkEndpoint methodsFor: 'protocol stack'!
downcallAll: collection
	"This is just for speed in telnet negotiation."

	socket isConnected
		ifTrue: [socket sendData: collection]
		ifFalse: [socket closeAndDestroy]! !

!NetworkEndpoint methodsFor: 'protocol stack'!
note: aSymbol with: anObject

	super note: aSymbol with: anObject.
	aSymbol == #connectedTo		ifTrue: [^self ttyMsgCR: 'Connected to ', anObject, '.'].
	aSymbol == #endpointClosed		ifTrue: [^self ttyCR; ttyMsgCR: 'Connection closed.'].
	aSymbol == #oobInlineEndpoint	ifTrue: [^socket setOption: 'SO_OOBINLINE' value: 1].
	aSymbol == #savePreferences		ifTrue: [^self savePreferences: anObject].! !

!NetworkEndpoint methodsFor: 'protocol stack'!
run

	self isConnected ifTrue: [self sessionNote: #connectedTo with: self name].
	super run! !

!NetworkEndpoint methodsFor: 'initialize-release'!
close

	socket notNil ifTrue: [socket close]! !

!NetworkEndpoint methodsFor: 'initialize-release'!
socket: aSocket

	socket _ aSocket! !

!NetworkEndpoint methodsFor: 'debugging'!
rcvd: char

	| str |
	str _ char asInteger printStringBase: 16.
	str _ str copyFrom: 4 to: str size.
	Transcript cr; nextPut: $<; tab; nextPutAll: (str padded: #left to: 2 with: $0); tab; nextPut: char asCharacter! !

!NetworkEndpoint methodsFor: 'debugging'!
sent: char

	| str |
	str _ char asInteger printStringBase: 16.
	str _ str copyFrom: 4 to: str size.
	Transcript cr; nextPut: $>; tab; nextPutAll: (str padded: #left to: 2 with: $0); tab; nextPut: char asCharacter! !

!NetworkEndpoint methodsFor: 'private'!
savePreferences: dict

	dict at: #endpointClass put: self class name.
	dict at: #endpointCreate put: #newConnection:port:.
	dict at: #endpointArguments put: (Array with: socket name with: socket remotePort)! !


!NetworkEndpoint class methodsFor: 'examples'!
example
	"NetworkEndpoint example"

	^NetworkEndpoint new
		socket: ((Socket initializeNetwork; new)
					connectTo: (NetNameResolver addressForName: 'localhost') port: 13;
					waitForConnectionUntil: (Socket deadlineSecs: 1);
					yourself);
		up: (ProtocolAdaptor new
				upBlock: [:arg | Transcript nextPut: arg asCharacter; endEntry]);
		run.! !

!NetworkEndpoint class methodsFor: 'examples'!
example2
	"NetworkEndpoint example2"

	| s |
	NetworkEndpoint new
		socket: ((s _ Socket initializeNetwork; new)
					connectTo: (NetNameResolver addressForName: 'localhost') port: 7;
					waitForConnectionUntil: (Socket deadlineSecs: 1);
					yourself);
		up: (ProtocolAdaptor new
				upBlock: [:arg | Transcript nextPut: arg asCharacter; endEntry]);
		run.
	s sendData: 'send this back to me'.
	(Delay forSeconds: 1) wait.
	s close! !

!NetworkEndpoint class methodsFor: 'examples'!
example3
	"NetworkEndpoint example3"

	| ep |
	(ep _ NetworkEndpoint newConnection: 'localhost' port: 7)
		up: (ProtocolAdaptor upBlock:
				[:arg | Transcript nextPut: arg asCharacter; endEntry]);
		run.
	ep socket sendData: 'send this back to me'.
	(Delay forSeconds: 1) wait.
	ep socket close! !

!NetworkEndpoint class methodsFor: 'examples'!
newConnection: host port: port

	| s addr |
	Socket initializeNetwork.
	(addr _ NetNameResolver addressForName: host) isNil
		ifTrue: [^nil].
	(s _ SafeSocket new)
		connectTo: addr port: port;
		waitForConnectionUntil: Socket standardDeadline.
	s isWaitingForConnection
		ifTrue: [s destroy. ^nil].
	s name: host.
	^self new socket: s! !


!ProcessEndpoint methodsFor: 'initialize-release'!
command: cmd arguments: args

	(pty _ PseudoTTY command: cmd arguments: args)
		isNil ifTrue: [^self error: 'could not create process'].
	command _ cmd.
	arguments _ args.! !

!ProcessEndpoint methodsFor: 'protocol'!
close

	pty close.! !

!ProcessEndpoint methodsFor: 'protocol'!
downcall: char

	pty nextPut: char! !

!ProcessEndpoint methodsFor: 'protocol'!
isConnected

	^pty isConnected! !

!ProcessEndpoint methodsFor: 'protocol'!
name

	^pty name! !

!ProcessEndpoint methodsFor: 'protocol'!
note: aSymbol with: anObject

	super note: aSymbol with: anObject.
	aSymbol == #windowSize		ifTrue: [^pty noteWindowSize: anObject "Point"].
	aSymbol == #endpointClosed	ifTrue: [^self ttyCR; ttyMsgCR: 'Process terminated.'].
	aSymbol == #savePreferences	ifTrue: [^self savePreferences: anObject]! !

!ProcessEndpoint methodsFor: 'server loop'!
getData
	"Answer the next chunk of stuff from the pty or nil if the pty has been closed."

	| buf |
	pty isConnected ifFalse: [^nil].
	Processor yield.
	(buf _ pty peekUpToEnd) isNil ifTrue: [up flush.  buf _ pty upToEnd].
	^buf! !

!ProcessEndpoint methodsFor: 'private'!
savePreferences: dict

	dict
		at: #endpointClass put: self class name;
		at: #endpointCreate put: #command:arguments:;
		at: #endpointArguments put: (Array with: command with: arguments)! !


!ProcessEndpoint class methodsFor: 'instance creation'!
command: command

	^self command: command arguments: nil! !

!ProcessEndpoint class methodsFor: 'instance creation'!
command: command arguments: arguments

	^self new command: command arguments: arguments! !

!ProcessEndpoint class methodsFor: 'instance creation'!
example
	"ProcessEndpoint example upToEnd asString"

	^ProcessEndpoint command: '/bin/bash' arguments: #('-ec' '/bin/pwd')! !

!ProcessEndpoint class methodsFor: 'instance creation'!
example2
	"ProcessEndpoint example2"

	| tty |
	^LayeredProtocol new
		addDown: (tty _ TeletypeMorph open);
		addDown: (XtermEmulator new window: tty);
		addDown: (ProcessEndpoint command: '/bin/bash' arguments: #('-i'));
		install;
		run! !

!ProcessEndpoint class methodsFor: 'instance creation'!
example3
	"ProcessEndpoint example3"

	^(LayeredProtocol
		on:		(ProcessEndpoint command: '/bin/bash' arguments: #('-i')))
		push:	XtermEmulator new;
		push:	TeletypeMorph open;
		install;
		run! !


!ProtocolState methodsFor: 'accessing'!
add: anAssociation

	^self transitionAt: anAssociation key put: (self transitionFor: anAssociation value)! !

!ProtocolState methodsFor: 'accessing'!
addAll: anAssociation

	^self atAll: anAssociation key put: anAssociation value! !

!ProtocolState methodsFor: 'accessing'!
addAllInteger: anAssociation

	^self atAllInteger: anAssociation key put: anAssociation value! !

!ProtocolState methodsFor: 'accessing'!
addInteger: anAssociation

	^self transitionAt: anAssociation key asInteger put: (self transitionFor: anAssociation value)! !

!ProtocolState methodsFor: 'accessing'!
at: key put: transition

	^self transitionAt: key put: (self transitionFor: transition)! !

!ProtocolState methodsFor: 'accessing'!
at: anObject to: limit put: transition

	| edge |
	edge _ self transitionFor: transition.
	anObject to: limit do: [:target | self transitionAt: target put: edge]! !

!ProtocolState methodsFor: 'accessing'!
atAll: collection put: transition
	| edge |
	edge _ self transitionFor: transition.
	collection do: [:elt | self transitionAt: elt put: edge]! !

!ProtocolState methodsFor: 'accessing'!
atAllInteger: collection put: transition
	| edge |
	edge _ self transitionFor: transition.
	collection do: [:elt | self transitionAt: elt asInteger put: edge]! !

!ProtocolState methodsFor: 'accessing'!
default

	^default! !

!ProtocolState methodsFor: 'accessing'!
default: transition

	self defaultTransition: (self transitionFor: transition)! !

!ProtocolState methodsFor: 'accessing'!
defaultTransition: aTransition

	default _ aTransition! !

!ProtocolState methodsFor: 'accessing'!
name

	^name! !

!ProtocolState methodsFor: 'accessing'!
name: aSymbol

	name _ aSymbol! !

!ProtocolState methodsFor: 'accessing'!
transitionAt: key

	^super at: key ifAbsent: [default]! !

!ProtocolState methodsFor: 'accessing'!
transitionAt: key put: edge

	^super at: key put: edge! !

!ProtocolState methodsFor: 'printing'!
printElementsOn: aStream

	aStream nextPutAll: '(name: ' , name printString.
	aStream nextPutAll: ' default: ' , default printString.
	aStream nextPutAll: ' transitions:'.
	self associationsDo: [:transition | aStream space.  transition printOn: aStream.].
	aStream nextPut: $).! !

!ProtocolState methodsFor: 'private'!
transitionFor: transition

	^ProtocolStateTransition action: transition key state: transition value! !


!ProtocolState class methodsFor: 'instance creation'!
name: myName default: aTransition
	^self new
		name: myName;
		default: aTransition! !

!ProtocolState class methodsFor: 'examples'!
example
	"ProtocolState example"

	^(self name: #initial default: #echo: -> #initial)
		at: 42 put: #echo42: -> #initial;
		yourself! !


!ProtocolStateTransition methodsFor: 'accessing'!
action

	^action! !

!ProtocolStateTransition methodsFor: 'accessing'!
action: aSymbol

	action _ aSymbol! !

!ProtocolStateTransition methodsFor: 'accessing'!
state

	^state! !

!ProtocolStateTransition methodsFor: 'accessing'!
state: aState

	state _ aState! !

!ProtocolStateTransition methodsFor: 'state transitions'!
transitionFrom: lastState for: aClient with: anObject

	action isNil ifFalse: [aClient perform: action with: anObject].
	^state isNil ifTrue: [lastState] ifFalse: [state]! !

!ProtocolStateTransition methodsFor: 'printing'!
printOn: aStream

	aStream nextPut: ${.
	action printOn: aStream.
	aStream nextPutAll: ' -> '.
	aStream nextPutAll: ((state isMemberOf: Symbol)
		ifTrue: [state]
		ifFalse: [state name]) printString.
	aStream nextPut: $}! !


!ProtocolStateTransition class methodsFor: 'instance creation'!
action: aSymbol

	^self new state: nil; action: aSymbol! !

!ProtocolStateTransition class methodsFor: 'instance creation'!
action: aSymbol state: aState

	^self new state: aState; action: aSymbol! !

!ProtocolStateTransition class methodsFor: 'instance creation'!
state: aState

	^self new state: aState; action: nil! !

!ProtocolStateTransition class methodsFor: 'instance creation'!
state: aState action: aSymbol

	^self new state: aState; action: aSymbol! !


!SafeSocket methodsFor: 'initialize-release'!
close

	super close.
	InstanceList remove: self ifAbsent: []! !

!SafeSocket methodsFor: 'initialize-release'!
connectTo: host port: port

	hostName _ host.
	^super connectTo: hostName port: port! !

!SafeSocket methodsFor: 'accessing'!
name
	"Answer the name of the peer."

	^self isConnected
		ifTrue: [hostName isNil ifTrue: [NetNameResolver stringFromAddress: self remoteAddress] ifFalse: [hostName]]
		ifFalse: ['not connected']! !

!SafeSocket methodsFor: 'accessing'!
name: aString
	"Set the name of the connection."

	hostName _ aString! !

!SafeSocket methodsFor: 'primitives'!
primSocketCloseConnection: socketID
	"Close the connection on the given port. The remote end is informed that this end has closed and will do no further sends. This is an asynchronous call; query the socket status to discover if and when the connection is actually closed.  Overriden to avoid primitive fail error in superclass."

	<primitive: 'primitiveSocketCloseConnection' module: 'SocketPlugin'>! !

!SafeSocket methodsFor: 'primitives'!
primSocketReceiveDataAvailable: socketID
	"Return true if data may be available for reading from the current socket.  Overridden to avoid primitive failure when the socket is closed asynchronously (or left open across snapshot and quit)."

	<primitive: 'primitiveSocketReceiveDataAvailable' module: 'SocketPlugin'>
	^false! !


!SafeSocket class methodsFor: 'class initialization'!
initialize
	"SafeSocket initialize"

	InstanceList _ IdentitySet new.
	Smalltalk
		addToStartUpList: self;
		addToShutDownList: self.! !

!SafeSocket class methodsFor: 'instance creation'!
new

	^InstanceList add: super new! !

!SafeSocket class methodsFor: 'snapshot'!
shutDown: quitting
	"We're about to snapshot and quit: shut down any open connections."

	InstanceList _ InstanceList select: [ :sock | sock isConnected].
	(quitting and: [InstanceList notEmpty]) ifTrue:
		[(self confirm: (String streamContents: [ :str |
				str nextPutAll: 'Open network connections exist to the following hosts:'.
				InstanceList do: [ :sock | str cr; tab; nextPutAll: sock name].
				str cr; nextPutAll: 'Do you want to shut them down before quitting?']))
			ifTrue: [InstanceList do: [:sock | sock close]]]! !

!SafeSocket class methodsFor: 'snapshot'!
startUp: resuming
	"We're coming back from snapshot and quit.  Close any connections that were left open in the snapshot."

	(resuming and: [InstanceList notEmpty])
		ifTrue: [InstanceList do: [ :sock | sock close]]! !


!SimpleTextMorph methodsFor: 'initialize-release'!
contents: aLineState
	"Initialize the receiver with the given contents."

	super initialize.
	font _ self defaultFont.
	fgMap _ Foreground shallowCopy.
	bgMap _ Background shallowCopy.
	lineState _ aLineState.
	pitch _ font widthOfString: ' '.
	color _ Color white.
	rv _ false.
	cursorColour _ nil.! !

!SimpleTextMorph methodsFor: 'initialize-release'!
initialize
	"Initialize the receiver with empty contents."

	self contents: SimpleTextState new.! !

!SimpleTextMorph methodsFor: 'accessing'!
cursorColour: cc

	cursorColour _ cc.! !

!SimpleTextMorph methodsFor: 'accessing'!
ec: aBoolean

	aBoolean ifTrue: [self emacsColours] ifFalse: [self normalColours]! !

!SimpleTextMorph methodsFor: 'accessing'!
emacsColours

	fgMap _ Foreground2 shallowCopy.
	bgMap _ Background2 shallowCopy.
	rv ifTrue: [self reversePolarity]! !

!SimpleTextMorph methodsFor: 'accessing'!
lineState
	"Answer an opaque representation of the line contents"

	^lineState! !

!SimpleTextMorph methodsFor: 'accessing'!
lineState: state
	"Restore the line contents from the given state"

	lineState _ state.
	state changed: true.		"force redraw on next cycle"! !

!SimpleTextMorph methodsFor: 'accessing'!
normalColours

	fgMap _ Foreground shallowCopy.
	bgMap _ Background shallowCopy.
	rv ifTrue: [self reversePolarity]! !

!SimpleTextMorph methodsFor: 'accessing'!
rv: aBoolean

	aBoolean ~~ rv
		ifTrue:
			[rv _ aBoolean.
			 self reversePolarity]! !

!SimpleTextMorph methodsFor: 'drawing'!
drawCursorOn: aCanvas

	| cc bg fg |
	lineState cursorColumn > 0 ifTrue:
		[cc _ lineState cursorColumn min: lineState stringSize.
		 (lineState selectionSpansColumn:  cc)
			ifTrue:
				[fg _ self backgroundColourAt: (lineState bgRuns at: cc).
				 bg _ self foregroundColourAt: (lineState fgRuns at: cc)]
			ifFalse:
				[bg _ self backgroundColourAt: (lineState bgRuns at: cc).
				 fg _ cursorColour isNil ifTrue: [self foregroundColourAt: (lineState fgRuns at: cc)] ifFalse: [cursorColour]].
		 owner hasFocus
			ifTrue: [aCanvas
				drawString: lineState string
				from: cc to: cc
				in: (bounds insetOriginBy: (pitch * (cc - 1) @ 0) cornerBy: 0@0)
				font: font
				color: bg
				background: fg]
			ifFalse: [aCanvas
				frameRectangle: (bounds origin + (pitch * (cc - 1) @ 0) extent: pitch @ font height)
				width: 1
				color: fg]].! !

!SimpleTextMorph methodsFor: 'drawing'!
drawLineOn: aCanvas

	| port tmp |
	self runsDo: [:l :r :fg :bg :em |
		port _ bounds left + (l - 1 * pitch) @ bounds top corner: bounds left + (lineState stringSize * pitch) @ bounds bottom.
		(em bitAnd: 64) == 64 ifTrue: [tmp _ fg.  fg _ bg.  bg _ tmp].
		aCanvas
			"fillRectangle: port fillStyle: bg;"
			drawString: lineState string
			from: l to: r in: port
			font: font
			color: fg
			background: bg.
		(em bitAnd: 1) == 1 ifTrue:	"bold"
			[aCanvas drawString: lineState string from: l to: r at: port topLeft + (1@0) font: font color: fg].
		(em bitAnd: 8) == 8 ifTrue:	"underline"
			[aCanvas line: port bottomLeft - (0@1) to: port bottomRight - (1@1) width: 1 color: fg]].
! !

!SimpleTextMorph methodsFor: 'drawing'!
drawOn: aCanvas

	super drawOn: aCanvas.
	self
		drawLineOn: aCanvas;
		drawCursorOn: aCanvas! !

!SimpleTextMorph methodsFor: 'drawing'!
fitContents
	"If the receiver has changed width then update my geometry."

	self extent: lineState stringSize * pitch @ font height! !

!SimpleTextMorph methodsFor: 'drawing'!
oldDrawLineOn: aCanvas

	| port tmp |
	self runsDo: [:l :r :fg :bg :em |
		port _ bounds insetOriginBy: (pitch * (l - 1) @ 0) cornerBy: 0@0.
		(em bitAnd: 64) == 64 ifTrue: [tmp _ fg.  fg _ bg.  bg _ tmp].
		aCanvas
			"fillRectangle: port fillStyle: bg;"
			drawString: lineState string
			from: l to: r in: port
			font: font
			color: fg
			background: bg.
		(em bitAnd: 1) == 1 ifTrue:	"bold"
			[aCanvas drawString: lineState string from: l to: r at: port topLeft + (1@0) font: font color: fg].
		(em bitAnd: 8) == 8 ifTrue:	"underline"
			[aCanvas line: port bottomLeft - (0@1) to: port bottomRight - (1@1) width: 1 color: fg]].
! !

!SimpleTextMorph methodsFor: 'selection'!
selectionColumnAt: screenPosition
	"Answer the column of the character at the given screen screenPosition.  If the screenPosition is within our bounds vertically but outside to the left or right then answer the first or last + 1 column respectively.  If the screenPosition is beyond lastCol then answer our width + 1."

	| x y col |
	x _ screenPosition x.
	y _ screenPosition y.
	(self bounds top <= y and: [self bounds bottom >= y]) ifFalse: [^nil].
	x <= self bounds left ifTrue: [^1].
	x >= self bounds right ifTrue: [^lineState stringSize + 1].
	col _ screenPosition x - self bounds left // pitch + 1 min: lineState stringSize max: 1.
	col > (lineState lastColumn + 1) ifTrue: [^lineState stringSize + 1].
	^col! !

!SimpleTextMorph methodsFor: 'private'!
backgroundColourAt: i

	^bgMap at: i + 1! !

!SimpleTextMorph methodsFor: 'private'!
defaultFont

	^((TextStyle named: DefaultStyle) isNil
		ifTrue: [TextStyle named: #Atlanta]
		ifFalse: [TextStyle named: DefaultStyle]) defaultFont! !

!SimpleTextMorph methodsFor: 'private'!
flush

	lineState changed
		ifTrue:
			[lineState changed: false.
			 self changed]! !

!SimpleTextMorph methodsFor: 'private'!
foregroundColourAt: i

	^fgMap at: i + 1! !

!SimpleTextMorph methodsFor: 'private'!
reversePolarity
	"It's almost daybreak and my method names are getting silly."

	fgMap swap: 1 with: fgMap size.
	bgMap swap: 1 with: bgMap size.! !

!SimpleTextMorph methodsFor: 'private'!
runsDo: aBlock

	| fg fgr bg bgr em emr left stringSize |
	stringSize _ lineState stringSize.
	bgr _ lineState bgRuns.  fgr _ lineState fgRuns.  emr _ lineState emRuns.
	bg _ bgr at: 1.  fg _ fgr at: 1.  em _ emr at: 1.
	left _ 1.
	2 to: stringSize do: [:i |
		(fg ~~ (fgr at: i) or: [bg ~~ (bgr at: i) or: [em ~~ (emr at: i)]])
			ifTrue:
				[aBlock
					value: left value: i - 1
					value: (self foregroundColourAt: fg)
					value: (self backgroundColourAt: bg)
					value: em.
				 bg _ bgr at: i.  fg _ fgr at: i.  em _ emr at: i.
				 left _ i]].
	aBlock
		value: left value: stringSize
		value: (self foregroundColourAt: fg)
		value: (self backgroundColourAt: bg)
		value: em! !


!SimpleTextMorph class methodsFor: 'class initialisation'!
initialize
	"SimpleTextMorph initialize"

	"ISO 6429 colour indices"
	Foreground _ #(black red green yellow blue magenta cyan white) collect: [:c | Color perform: c].
	Background _ #(black red green yellow blue magenta cyan white) collect: [:c | Color perform: c].
	"Alternate colour scheme for Emacs: reversed white/black on dark slate grey"
	(Foreground2 _ Foreground shallowCopy) at: 1 put: (Color white); at: 8 put: (Color black).
	(Background2 _ Background shallowCopy) at: 1 put: (Color white); at: 8 put: (Color fromString: '#314D52').
	false ifTrue: [
	2 to: 7 do: [:i |
		Foreground2 at: i put: ((Foreground2 at: i) adjustSaturation: -0.35 brightness: 0.5).
		Background2 at: i put: ((Background2 at: i) adjustSaturation: -0.35 brightness: 0.5)].
	] ifFalse: [
	(Foreground2 _ Foreground collect: [:c | c adjustSaturation: -0.35 brightness: 0.5])
		at: 1 put: (Color white "fromString: '#f7dfb5'"); at: 8 put: (Color black).
	(Background2 _ Background collect: [:c | c adjustSaturation: -0.35 brightness: 0.5])
		at: 1 put: (Color white); at: 8 put: (Color fromString: '#314D52').
	].
	"Offer to create the standard X11 'fixed' font with VT100 graphics and line-drawing characters"
	(TextStyle named: #Fixed) isNil ifTrue: [self initializeFonts].
	self defaultFont: #Fixed.! !

!SimpleTextMorph class methodsFor: 'class initialisation'!
initializeFonts
	"SimpleTextMorph initializeFonts"

	| file |
	(self confirm: 'The default fixed-width font is abominable.
Do you want me to create a better fixed-width font for you?')
		ifFalse: [^self].
	file _ FileStream newFileNamed: 'SimpleTextMorph-fixed.bdf'.
	file nextPutAll: self fixedFontDefinition; close.
	TextConstants at: #Fixed put: (TextStyle fontArray:
		{StrikeFont newFromBDFFile: 'SimpleTextMorph-fixed.bdf' name: 'Fixed13'}).
	FileDirectory default deleteFileNamed: 'SimpleTextMorph-fixed.bdf'.
	self inform: 'Font created as TextStyle named: #Fixed'.
"---
	(self confirm: 'The previous font is a little small on some high-resolution displays.
Would you also like me to create a larger fixed-width font for you?')
		ifFalse: [^self].
	file _ FileStream newFileNamed: 'SimpleTextMorph-lucida.bdf'.
	file nextPutAll: self fixedFontDefinition2; close.
	TextConstants at: #LucidaConsole put: (TextStyle fontArray:
		{StrikeFont newFromBDFFile: 'SimpleTextMorph-lucida.bdf' name: 'LucidaConsole12'}).
	FileDirectory default deleteFileNamed: 'SimpleTextMorph-lucida.bdf'.
	self inform: 'Font created as TextStyle named: #LucidaConsole'.
---"
! !

!SimpleTextMorph class methodsFor: 'instance creation'!
contents: lineState

	^super new contents: lineState! !

!SimpleTextMorph class methodsFor: 'instance creation'!
new

	^super new initialize! !

!SimpleTextMorph class methodsFor: 'accessing'!
defaultFont

	^DefaultStyle! !

!SimpleTextMorph class methodsFor: 'accessing'!
defaultFont: fontName

	DefaultStyle _ fontName! !

!SimpleTextMorph class methodsFor: 'examples'!
example

	"SimpleTextMorph example"

	| m |
	(m _ SimpleTextMorph new) lineState string: (String streamContents: [:s |
			0 to: 79 do: [:i | s nextPut: (Character value: i \\ 26 + $a asciiValue)]]).
	1 to: 80 do: [:i |
		m lineState foregroundAt: i put: i \\ 8.
		m lineState backgroundAt: i put: i - 1// 10].
	m openInWorld; fitContents; flush.
	^m! !

!SimpleTextMorph class methodsFor: 'examples'!
example2
	"One way (the wrong way) to implement blinking cursors."
	"SimpleTextMorph example2"

	| m |
	(m _ SimpleTextMorph new) lineState string: ('Hello, world.' padded: #right to: 80 with: $ ).
	m openInWorld; fitContents.
	[10 timesRepeat:
		[m lineState backgroundAt: 14 put: 0.  m flush.
		 (Delay forMilliseconds: 600) wait.
		 m lineState backgroundAt: 14 put: 7; changed.  m flush.
		 (Delay forMilliseconds: 300) wait].
	 m abandon] forkAt: Processor highIOPriority.
	^m! !

!SimpleTextMorph class methodsFor: 'examples'!
example3
	"SimpleTextMorph example3"

	| m |
	(m _ SimpleTextMorph new) lineState string: ('Hello, world.' padded: #right to: 80 with: $ ).
	m openInWorld; fitContents.
	m cursorColour: Preferences textHighlightColor.
	m lineState cursorCol: 14.
	^m! !

!SimpleTextMorph class methodsFor: 'private'!
fixedFontDefinition
	"This is -misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-iso8859-1 (aka 'fixed')"

	^'STARTFONT 2.1
COMMENT $XConsortium: 6x13.bdf,v 1.13 92/04/02 14:24:50 gildea Exp $
COMMENT ""
COMMENT Characters above 127 designed and made by
COMMENT Thomas Bagli (pyramid!!pcsbst!!tom@uunet.UU.NET)
COMMENT PCS Computer Systeme, West Germany
COMMENT ""
FONT -Misc-Fixed-Medium-R-SemiCondensed--13-120-75-75-C-60-ISO8859-1
SIZE 13 78 78
FONTBOUNDINGBOX 6 13 0 -2
STARTPROPERTIES 19
FONTNAME_REGISTRY ""
FOUNDRY "Misc"
FAMILY_NAME "Fixed"
WEIGHT_NAME "Medium"
SLANT "R"
SETWIDTH_NAME "SemiCondensed"
ADD_STYLE_NAME ""
PIXEL_SIZE 13
POINT_SIZE 120
RESOLUTION_X 75
RESOLUTION_Y 75
SPACING "C"
AVERAGE_WIDTH 60
CHARSET_REGISTRY "ISO8859"
CHARSET_ENCODING "1"
DEFAULT_CHAR 0
FONT_DESCENT 2
FONT_ASCENT 11
COPYRIGHT "Public domain font.  Share and enjoy."
ENDPROPERTIES
CHARS 224
STARTCHAR ascii000
ENCODING 0
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
78
78
78
78
78
78
78
78
78
78
78
00
ENDCHAR
STARTCHAR ascii001
ENCODING 1
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
20
70
f8
70
20
00
00
00
ENDCHAR
STARTCHAR ascii002
ENCODING 2
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
54
a8
54
a8
54
a8
54
a8
54
a8
54
a8
ENDCHAR
STARTCHAR ascii003
ENCODING 3
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
a0
a0
e0
a0
a0
70
20
20
20
ENDCHAR
STARTCHAR ascii004
ENCODING 4
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
e0
80
c0
80
f0
40
60
40
40
ENDCHAR
STARTCHAR ascii005
ENCODING 5
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
70
80
80
70
70
48
70
50
48
ENDCHAR
STARTCHAR ascii006
ENCODING 6
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
80
80
80
e0
70
40
60
40
40
ENDCHAR
STARTCHAR ascii007
ENCODING 7
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
60
90
90
60
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR ascii010
ENCODING 8
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
20
20
f8
20
20
00
f8
00
00
ENDCHAR
STARTCHAR ascii011
ENCODING 9
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
88
c8
a8
98
88
40
40
40
78
ENDCHAR
STARTCHAR ascii012
ENCODING 10
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
88
88
50
20
00
f8
20
20
20
ENDCHAR
STARTCHAR ascii013
ENCODING 11
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
20
20
20
20
20
20
20
e0
00
00
00
00
00
ENDCHAR
STARTCHAR ascii014
ENCODING 12
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
e0
20
20
20
20
20
ENDCHAR
STARTCHAR ascii015
ENCODING 13
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
3c
20
20
20
20
20
ENDCHAR
STARTCHAR ascii016
ENCODING 14
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
20
20
20
20
20
20
20
3c
00
00
00
00
00
ENDCHAR
STARTCHAR ascii017
ENCODING 15
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
20
20
20
20
20
20
20
fc
20
20
20
20
20
ENDCHAR
STARTCHAR ascii020
ENCODING 16
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
fc
00
00
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR ascii021
ENCODING 17
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
fc
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR ascii022
ENCODING 18
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
fc
00
00
00
00
00
ENDCHAR
STARTCHAR ascii023
ENCODING 19
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
00
00
fc
00
00
00
ENDCHAR
STARTCHAR ascii024
ENCODING 20
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
00
00
00
00
fc
00
ENDCHAR
STARTCHAR ascii025
ENCODING 21
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
20
20
20
20
20
20
20
3c
20
20
20
20
20
ENDCHAR
STARTCHAR ascii026
ENCODING 22
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
20
20
20
20
20
20
20
e0
20
20
20
20
20
ENDCHAR
STARTCHAR ascii027
ENCODING 23
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
20
20
20
20
20
20
20
fc
00
00
00
00
00
ENDCHAR
STARTCHAR ascii030
ENCODING 24
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
fc
20
20
20
20
20
ENDCHAR
STARTCHAR ascii031
ENCODING 25
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
20
20
20
20
20
20
20
20
20
20
20
20
20
ENDCHAR
STARTCHAR ascii032
ENCODING 26
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
08
10
20
40
20
10
08
f8
00
00
ENDCHAR
STARTCHAR ascii033
ENCODING 27
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
80
40
20
10
20
40
80
f8
00
00
ENDCHAR
STARTCHAR ascii034
ENCODING 28
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
f8
50
50
50
50
90
00
00
ENDCHAR
STARTCHAR ascii035
ENCODING 29
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
08
f8
20
f8
80
00
00
00
ENDCHAR
STARTCHAR ascii036
ENCODING 30
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
30
48
40
40
e0
40
40
48
b0
00
00
ENDCHAR
STARTCHAR ascii037
ENCODING 31
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
00
20
00
00
00
00
ENDCHAR
STARTCHAR space
ENCODING 32
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR exclam
ENCODING 33
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
20
20
20
20
20
20
20
00
20
00
00
ENDCHAR
STARTCHAR quotedbl
ENCODING 34
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
50
50
50
00
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR numbersign
ENCODING 35
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
50
50
f8
50
f8
50
50
00
00
00
ENDCHAR
STARTCHAR dollar
ENCODING 36
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
20
78
a0
a0
70
28
28
f0
20
00
00
ENDCHAR
STARTCHAR percent
ENCODING 37
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
48
a8
50
10
20
40
50
a8
90
00
00
ENDCHAR
STARTCHAR ampersand
ENCODING 38
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
40
a0
a0
40
a0
98
90
68
00
00
00
ENDCHAR
STARTCHAR quoteright
ENCODING 39
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
30
20
40
00
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR parenleft
ENCODING 40
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
10
20
20
40
40
40
20
20
10
00
00
ENDCHAR
STARTCHAR parenright
ENCODING 41
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
40
20
20
10
10
10
20
20
40
00
00
ENDCHAR
STARTCHAR asterisk
ENCODING 42
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
20
a8
f8
70
f8
a8
20
00
00
00
ENDCHAR
STARTCHAR plus
ENCODING 43
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
20
20
f8
20
20
00
00
00
00
ENDCHAR
STARTCHAR comma
ENCODING 44
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
00
00
30
20
40
00
ENDCHAR
STARTCHAR hyphen
ENCODING 45
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
f8
00
00
00
00
00
00
ENDCHAR
STARTCHAR period
ENCODING 46
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
00
00
20
70
20
00
ENDCHAR
STARTCHAR slash
ENCODING 47
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
08
08
10
10
20
40
40
80
80
00
00
ENDCHAR
STARTCHAR zero
ENCODING 48
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
20
50
88
88
88
88
88
50
20
00
00
ENDCHAR
STARTCHAR one
ENCODING 49
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
20
60
a0
20
20
20
20
20
f8
00
00
ENDCHAR
STARTCHAR two
ENCODING 50
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
88
88
08
10
20
40
80
f8
00
00
ENDCHAR
STARTCHAR three
ENCODING 51
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f8
08
10
20
70
08
08
88
70
00
00
ENDCHAR
STARTCHAR four
ENCODING 52
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
10
10
30
50
50
90
f8
10
10
00
00
ENDCHAR
STARTCHAR five
ENCODING 53
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f8
80
80
b0
c8
08
08
88
70
00
00
ENDCHAR
STARTCHAR six
ENCODING 54
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
88
80
80
f0
88
88
88
70
00
00
ENDCHAR
STARTCHAR seven
ENCODING 55
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f8
08
10
10
20
20
40
40
40
00
00
ENDCHAR
STARTCHAR eight
ENCODING 56
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
88
88
88
70
88
88
88
70
00
00
ENDCHAR
STARTCHAR nine
ENCODING 57
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
88
88
88
78
08
08
88
70
00
00
ENDCHAR
STARTCHAR colon
ENCODING 58
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
20
70
20
00
00
20
70
20
00
ENDCHAR
STARTCHAR semicolon
ENCODING 59
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
20
70
20
00
00
30
20
40
00
ENDCHAR
STARTCHAR less
ENCODING 60
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
08
10
20
40
80
40
20
10
08
00
00
ENDCHAR
STARTCHAR equal
ENCODING 61
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
f8
00
00
f8
00
00
00
00
ENDCHAR
STARTCHAR greater
ENCODING 62
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
80
40
20
10
08
10
20
40
80
00
00
ENDCHAR
STARTCHAR question
ENCODING 63
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
88
88
08
10
20
20
00
20
00
00
ENDCHAR
STARTCHAR at
ENCODING 64
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
88
88
98
a8
a8
b0
80
78
00
00
ENDCHAR
STARTCHAR A
ENCODING 65
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
20
50
88
88
88
f8
88
88
88
00
00
ENDCHAR
STARTCHAR B
ENCODING 66
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f0
48
48
48
70
48
48
48
f0
00
00
ENDCHAR
STARTCHAR C
ENCODING 67
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
88
80
80
80
80
80
88
70
00
00
ENDCHAR
STARTCHAR D
ENCODING 68
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f0
48
48
48
48
48
48
48
f0
00
00
ENDCHAR
STARTCHAR E
ENCODING 69
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f8
80
80
80
f0
80
80
80
f8
00
00
ENDCHAR
STARTCHAR F
ENCODING 70
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f8
80
80
80
f0
80
80
80
80
00
00
ENDCHAR
STARTCHAR G
ENCODING 71
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
88
80
80
80
98
88
88
70
00
00
ENDCHAR
STARTCHAR H
ENCODING 72
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
88
88
88
88
f8
88
88
88
88
00
00
ENDCHAR
STARTCHAR I
ENCODING 73
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
20
20
20
20
20
20
20
70
00
00
ENDCHAR
STARTCHAR J
ENCODING 74
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
38
10
10
10
10
10
10
90
60
00
00
ENDCHAR
STARTCHAR K
ENCODING 75
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
88
88
90
a0
c0
a0
90
88
88
00
00
ENDCHAR
STARTCHAR L
ENCODING 76
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
80
80
80
80
80
80
80
80
f8
00
00
ENDCHAR
STARTCHAR M
ENCODING 77
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
88
88
d8
a8
a8
88
88
88
88
00
00
ENDCHAR
STARTCHAR N
ENCODING 78
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
88
c8
c8
a8
a8
98
98
88
88
00
00
ENDCHAR
STARTCHAR O
ENCODING 79
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
88
88
88
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR P
ENCODING 80
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f0
88
88
88
f0
80
80
80
80
00
00
ENDCHAR
STARTCHAR Q
ENCODING 81
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
88
88
88
88
88
88
a8
70
08
00
ENDCHAR
STARTCHAR R
ENCODING 82
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f0
88
88
88
f0
a0
90
88
88
00
00
ENDCHAR
STARTCHAR S
ENCODING 83
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
88
80
80
70
08
08
88
70
00
00
ENDCHAR
STARTCHAR T
ENCODING 84
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f8
20
20
20
20
20
20
20
20
00
00
ENDCHAR
STARTCHAR U
ENCODING 85
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
88
88
88
88
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR V
ENCODING 86
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
88
88
88
88
50
50
50
20
20
00
00
ENDCHAR
STARTCHAR W
ENCODING 87
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
88
88
88
88
a8
a8
a8
d8
88
00
00
ENDCHAR
STARTCHAR X
ENCODING 88
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
88
88
50
50
20
50
50
88
88
00
00
ENDCHAR
STARTCHAR Y
ENCODING 89
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
88
88
50
50
20
20
20
20
20
00
00
ENDCHAR
STARTCHAR Z
ENCODING 90
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f8
08
10
10
20
40
40
80
f8
00
00
ENDCHAR
STARTCHAR braketleft
ENCODING 91
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
40
40
40
40
40
40
40
70
00
00
ENDCHAR
STARTCHAR backslash
ENCODING 92
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
80
80
40
40
20
10
10
08
08
00
00
ENDCHAR
STARTCHAR bracketright
ENCODING 93
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
10
10
10
10
10
10
10
70
00
00
ENDCHAR
STARTCHAR asciicircum
ENCODING 94
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
20
50
88
00
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR underscore
ENCODING 95
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
00
00
00
00
f8
00
ENDCHAR
STARTCHAR quoteleft
ENCODING 96
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
30
10
08
00
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR a
ENCODING 97
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
70
08
78
88
88
78
00
00
ENDCHAR
STARTCHAR b
ENCODING 98
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
80
80
80
f0
88
88
88
88
f0
00
00
ENDCHAR
STARTCHAR c
ENCODING 99
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
70
88
80
80
88
70
00
00
ENDCHAR
STARTCHAR d
ENCODING 100
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
08
08
08
78
88
88
88
88
78
00
00
ENDCHAR
STARTCHAR e
ENCODING 101
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
70
88
f8
80
88
70
00
00
ENDCHAR
STARTCHAR f
ENCODING 102
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
30
48
40
40
f0
40
40
40
40
00
00
ENDCHAR
STARTCHAR g
ENCODING 103
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
70
88
88
88
78
08
88
70
ENDCHAR
STARTCHAR h
ENCODING 104
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
80
80
80
b0
c8
88
88
88
88
00
00
ENDCHAR
STARTCHAR i
ENCODING 105
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
20
00
60
20
20
20
20
70
00
00
ENDCHAR
STARTCHAR j
ENCODING 106
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
10
00
30
10
10
10
10
90
90
60
ENDCHAR
STARTCHAR k
ENCODING 107
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
80
80
80
90
a0
c0
a0
90
88
00
00
ENDCHAR
STARTCHAR l
ENCODING 108
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
60
20
20
20
20
20
20
20
70
00
00
ENDCHAR
STARTCHAR m
ENCODING 109
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
d0
a8
a8
a8
a8
88
00
00
ENDCHAR
STARTCHAR n
ENCODING 110
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
b0
c8
88
88
88
88
00
00
ENDCHAR
STARTCHAR o
ENCODING 111
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
70
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR p
ENCODING 112
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
f0
88
88
88
f0
80
80
80
ENDCHAR
STARTCHAR q
ENCODING 113
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
78
88
88
88
78
08
08
08
ENDCHAR
STARTCHAR r
ENCODING 114
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
b0
c8
80
80
80
80
00
00
ENDCHAR
STARTCHAR s
ENCODING 115
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
70
88
60
10
88
70
00
00
ENDCHAR
STARTCHAR t
ENCODING 116
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
40
40
f0
40
40
40
48
30
00
00
ENDCHAR
STARTCHAR u
ENCODING 117
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
88
88
88
88
98
68
00
00
ENDCHAR
STARTCHAR v
ENCODING 118
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
88
88
88
50
50
20
00
00
ENDCHAR
STARTCHAR w
ENCODING 119
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
88
88
a8
a8
a8
50
00
00
ENDCHAR
STARTCHAR x
ENCODING 120
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
88
50
20
20
50
88
00
00
ENDCHAR
STARTCHAR y
ENCODING 121
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
88
88
88
98
68
08
88
70
ENDCHAR
STARTCHAR z
ENCODING 122
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
f8
10
20
40
80
f8
00
00
ENDCHAR
STARTCHAR braceleft
ENCODING 123
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
18
20
20
20
c0
20
20
20
18
00
00
ENDCHAR
STARTCHAR bar
ENCODING 124
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
20
20
20
20
20
20
20
20
20
00
00
ENDCHAR
STARTCHAR braceright
ENCODING 125
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
c0
20
20
20
18
20
20
20
c0
00
00
ENDCHAR
STARTCHAR asciitilde
ENCODING 126
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
48
a8
90
00
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR ascii177
ENCODING 127
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR 00a0
ENCODING 160
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR 00a1
ENCODING 161
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
20
00
20
20
20
20
20
20
20
00
00
ENDCHAR
STARTCHAR 00a2
ENCODING 162
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
20
70
a8
a0
a0
a8
70
20
00
00
00
ENDCHAR
STARTCHAR 00a3
ENCODING 163
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
30
48
40
40
e0
40
40
48
b0
00
00
ENDCHAR
STARTCHAR 00a4
ENCODING 164
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
88
70
50
50
70
88
00
00
00
ENDCHAR
STARTCHAR 00a5
ENCODING 165
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
88
88
50
50
f8
20
f8
20
20
00
00
ENDCHAR
STARTCHAR 00a6
ENCODING 166
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
20
20
20
20
00
20
20
20
20
00
00
ENDCHAR
STARTCHAR 00a7
ENCODING 167
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
30
48
40
30
48
48
30
08
48
30
00
00
ENDCHAR
STARTCHAR 00a8
ENCODING 168
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
d8
00
00
00
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR 00a9
ENCODING 169
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
70
88
a8
d8
c8
d8
a8
88
70
00
00
00
ENDCHAR
STARTCHAR 00aa
ENCODING 170
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
08
78
88
78
00
f8
00
00
00
00
ENDCHAR
STARTCHAR 00ab
ENCODING 171
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
28
50
a0
a0
50
28
00
00
00
ENDCHAR
STARTCHAR 00ac
ENCODING 172
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
f8
08
08
00
00
00
00
ENDCHAR
STARTCHAR 00ad
ENCODING 173
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
f8
00
00
00
00
00
00
ENDCHAR
STARTCHAR 00ae
ENCODING 174
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
70
88
e8
d8
d8
e8
d8
88
70
00
00
00
ENDCHAR
STARTCHAR 00af
ENCODING 175
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f8
00
00
00
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR 00b0
ENCODING 176
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
30
48
48
30
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR 00b1
ENCODING 177
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
20
20
f8
20
20
00
f8
00
00
00
ENDCHAR
STARTCHAR 00b2
ENCODING 178
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
40
a0
20
40
e0
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR 00b3
ENCODING 179
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
40
a0
40
20
c0
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR 00b4
ENCODING 180
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
00
00
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR 00b5
ENCODING 181
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
88
88
88
88
98
e8
80
00
ENDCHAR
STARTCHAR 00b6
ENCODING 182
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
78
e8
e8
e8
e8
68
28
28
28
00
00
ENDCHAR
STARTCHAR 00b7
ENCODING 183
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
30
00
00
00
00
00
00
ENDCHAR
STARTCHAR 00b8
ENCODING 184
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
00
00
00
00
00
00
10
20
ENDCHAR
STARTCHAR 00b9
ENCODING 185
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
40
c0
40
40
e0
00
00
00
00
00
00
00
ENDCHAR
STARTCHAR 00ba
ENCODING 186
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
30
48
48
30
00
78
00
00
00
00
00
ENDCHAR
STARTCHAR 00bb
ENCODING 187
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
a0
50
28
28
50
a0
00
00
00
ENDCHAR
STARTCHAR 00bc
ENCODING 188
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
40
c0
40
40
e0
08
18
28
38
08
00
00
ENDCHAR
STARTCHAR 00bd
ENCODING 189
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
40
c0
40
40
e0
10
28
08
10
38
00
00
ENDCHAR
STARTCHAR 00be
ENCODING 190
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
40
a0
40
20
a0
48
18
28
38
08
00
00
ENDCHAR
STARTCHAR 00bf
ENCODING 191
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
20
00
20
20
40
80
88
88
70
00
00
ENDCHAR
STARTCHAR 00c0
ENCODING 192
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
20
10
00
20
50
88
88
f8
88
88
00
00
ENDCHAR
STARTCHAR 00c1
ENCODING 193
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
20
50
88
88
f8
88
88
00
00
ENDCHAR
STARTCHAR 00c2
ENCODING 194
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
30
48
00
20
50
88
88
f8
88
88
00
00
ENDCHAR
STARTCHAR 00c3
ENCODING 195
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
28
50
00
20
50
88
88
f8
88
88
00
00
ENDCHAR
STARTCHAR 00c4
ENCODING 196
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
50
50
00
20
50
88
88
f8
88
88
00
00
ENDCHAR
STARTCHAR 00c5
ENCODING 197
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
20
50
20
20
50
88
88
f8
88
88
00
00
ENDCHAR
STARTCHAR 00c6
ENCODING 198
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
58
a0
a0
a0
b0
e0
a0
a0
b8
00
00
ENDCHAR
STARTCHAR 00c7
ENCODING 199
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
70
88
80
80
80
80
80
88
70
20
40
ENDCHAR
STARTCHAR 00c8
ENCODING 200
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
20
10
00
f8
80
80
f0
80
80
f8
00
00
ENDCHAR
STARTCHAR 00c9
ENCODING 201
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
f8
80
80
f0
80
80
f8
00
00
ENDCHAR
STARTCHAR 00ca
ENCODING 202
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
60
90
00
f8
80
80
f0
80
80
f8
00
00
ENDCHAR
STARTCHAR 00cb
ENCODING 203
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
50
50
00
f8
80
80
f0
80
80
f8
00
00
ENDCHAR
STARTCHAR 00cc
ENCODING 204
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
20
10
00
f8
20
20
20
20
20
f8
00
00
ENDCHAR
STARTCHAR 00cd
ENCODING 205
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
f8
20
20
20
20
20
f8
00
00
ENDCHAR
STARTCHAR 00ce
ENCODING 206
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
30
48
00
f8
20
20
20
20
20
f8
00
00
ENDCHAR
STARTCHAR 00cf
ENCODING 207
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
50
50
00
f8
20
20
20
20
20
f8
00
00
ENDCHAR
STARTCHAR 00d0
ENCODING 208
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
f0
48
48
48
e8
48
48
48
f0
00
00
ENDCHAR
STARTCHAR 00d1
ENCODING 209
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
28
50
00
88
88
c8
a8
98
88
88
00
00
ENDCHAR
STARTCHAR 00d2
ENCODING 210
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
20
10
00
70
88
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00d3
ENCODING 211
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
70
88
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00d4
ENCODING 212
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
30
48
00
70
88
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00d5
ENCODING 213
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
28
50
00
70
88
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00d6
ENCODING 214
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
50
50
00
70
88
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00d7
ENCODING 215
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
88
50
20
50
88
00
00
00
ENDCHAR
STARTCHAR 00d8
ENCODING 216
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
08
70
98
98
a8
a8
a8
c8
c8
70
80
00
ENDCHAR
STARTCHAR 00d9
ENCODING 217
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
20
10
00
88
88
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00da
ENCODING 218
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
88
88
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00db
ENCODING 219
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
30
48
00
88
88
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00dc
ENCODING 220
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
50
50
00
88
88
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00dd
ENCODING 221
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
88
88
50
20
20
20
20
00
00
ENDCHAR
STARTCHAR 00de
ENCODING 222
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
80
f0
88
88
88
f0
80
80
80
00
00
ENDCHAR
STARTCHAR 00df
ENCODING 223
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
70
88
88
f0
88
88
c8
b0
80
00
ENDCHAR
STARTCHAR 00e0
ENCODING 224
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
20
10
00
00
70
08
78
88
98
68
00
00
ENDCHAR
STARTCHAR 00e1
ENCODING 225
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
00
70
08
78
88
98
68
00
00
ENDCHAR
STARTCHAR 00e2
ENCODING 226
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
30
48
00
00
70
08
78
88
98
68
00
00
ENDCHAR
STARTCHAR 00e3
ENCODING 227
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
28
50
00
00
70
08
78
88
98
68
00
00
ENDCHAR
STARTCHAR 00e4
ENCODING 228
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
50
50
00
00
70
08
78
88
98
68
00
00
ENDCHAR
STARTCHAR 00e5
ENCODING 229
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
30
48
30
00
70
08
78
88
98
68
00
00
ENDCHAR
STARTCHAR 00e6
ENCODING 230
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
70
28
70
a0
a8
50
00
00
ENDCHAR
STARTCHAR 00e7
ENCODING 231
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
00
70
88
80
80
88
70
20
40
ENDCHAR
STARTCHAR 00e8
ENCODING 232
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
20
10
00
00
70
88
f8
80
88
70
00
00
ENDCHAR
STARTCHAR 00e9
ENCODING 233
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
00
70
88
f8
80
88
70
00
00
ENDCHAR
STARTCHAR 00ea
ENCODING 234
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
30
48
00
00
70
88
f8
80
88
70
00
00
ENDCHAR
STARTCHAR 00eb
ENCODING 235
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
50
50
00
00
70
88
f8
80
88
70
00
00
ENDCHAR
STARTCHAR 00ec
ENCODING 236
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
20
10
00
00
60
20
20
20
20
f8
00
00
ENDCHAR
STARTCHAR 00ed
ENCODING 237
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
00
60
20
20
20
20
f8
00
00
ENDCHAR
STARTCHAR 00ee
ENCODING 238
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
30
48
00
00
60
20
20
20
20
f8
00
00
ENDCHAR
STARTCHAR 00ef
ENCODING 239
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
50
50
00
00
60
20
20
20
20
f8
00
00
ENDCHAR
STARTCHAR 00f0
ENCODING 240
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
50
20
60
10
70
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00f1
ENCODING 241
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
28
50
00
00
b0
c8
88
88
88
88
00
00
ENDCHAR
STARTCHAR 00f2
ENCODING 242
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
20
10
00
00
70
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00f3
ENCODING 243
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
00
70
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00f4
ENCODING 244
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
30
48
00
00
70
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00f5
ENCODING 245
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
28
50
00
00
70
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00f6
ENCODING 246
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
50
50
00
00
70
88
88
88
88
70
00
00
ENDCHAR
STARTCHAR 00f7
ENCODING 247
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
20
20
00
f8
00
20
20
00
00
00
ENDCHAR
STARTCHAR 00f8
ENCODING 248
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
00
08
70
98
a8
a8
c8
70
80
00
ENDCHAR
STARTCHAR 00f9
ENCODING 249
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
20
10
00
00
88
88
88
88
88
78
00
00
ENDCHAR
STARTCHAR 00fa
ENCODING 250
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
00
88
88
88
88
88
78
00
00
ENDCHAR
STARTCHAR 00fb
ENCODING 251
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
30
48
00
00
88
88
88
88
88
78
00
00
ENDCHAR
STARTCHAR 00fc
ENCODING 252
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
50
50
00
00
88
88
88
88
88
78
00
00
ENDCHAR
STARTCHAR 00fd
ENCODING 253
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
10
20
00
00
88
88
88
98
68
08
88
70
ENDCHAR
STARTCHAR 00fe
ENCODING 254
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
00
00
80
80
b0
c8
88
88
c8
b0
80
80
ENDCHAR
STARTCHAR 00ff
ENCODING 255
SWIDTH 461 0
DWIDTH 6 0
BBX 6 13 0 -2
BITMAP
00
50
50
00
00
88
88
88
98
68
08
88
70
ENDCHAR
ENDFONT
'! !


!SimpleTextState methodsFor: 'initialize-release'!
initialize
	"Initialize the receiver with empty contents."

	self initialize: (String new: 0)! !

!SimpleTextState methodsFor: 'initialize-release'!
initialize: aString
	"Initialize the receiver with the given contents."

	string _ aString.
	stringSize _ string size.
	fgRuns _ Array new: stringSize withAll: 0.
	bgRuns _ Array new: stringSize withAll: 7.
	emRuns _ Array new: stringSize withAll: 0.
	cursorCol _ 0.
	changed _ true.	"want initial display"
	selection _ nil.
	lastCol _ 0.! !

!SimpleTextState methodsFor: 'accessing'!
at: index insert: char fg: fg bg: bg em: em

	stringSize - 1 to: index by: -1 do: [:i |
		string at: i + 1 put: (string at: i).
		fgRuns at: i + 1 put: (fgRuns at: i).
		bgRuns at: i + 1 put: (bgRuns at: i).
		emRuns at: i + 1 put: (emRuns at: i)].
	string at: index put: char.
	self foregroundAt: index put: fg.
	self backgroundAt: index put: bg.
	lastCol _ lastCol + 1 min: stringSize max: index.
	changed _ true! !

!SimpleTextState methodsFor: 'accessing'!
at: index put: char fg: fg bg: bg em: em

	((string at: index) ~~ char
			or: [(fgRuns at: index) ~~ fg
			or: [(bgRuns at: index) ~~ bg
			or: [(emRuns at: index) ~~em]]])
		ifTrue:
			[string at: index put: char.
			 self foregroundAt: index put: fg.
			 self backgroundAt: index put: bg.
			 emRuns at: index put: em.
			 lastCol _ lastCol max: index.
			 changed _ true]! !

!SimpleTextState methodsFor: 'accessing'!
atAllPut: char fg: fg bg: bg em: em
	"Update the receiver's string, colour and emphasis."

	string from: 1 to: stringSize put: char.
	fgRuns from: 1 to: stringSize put: fg.
	bgRuns from: 1 to: stringSize put: bg.
	emRuns from: 1 to: stringSize put: em.
	lastCol _ char == $  ifTrue: [1] ifFalse: [stringSize].
	changed _ true! !

!SimpleTextState methodsFor: 'accessing'!
background: bgIndex

	1 to: stringSize do: [:i | self backgroundAt: i put: bgIndex]! !

!SimpleTextState methodsFor: 'accessing'!
backgroundAt: index put: c

	(bgRuns at: index) ~~ c
		ifTrue:
			[bgRuns at: index put: c.
			 changed _ true]! !

!SimpleTextState methodsFor: 'accessing'!
basicAt: index put: char fg: fg bg: bg em: em

	string at: index put: char.
	self foregroundAt: index put: fg.
	self backgroundAt: index put: bg.
	emRuns at: index put: em.
	lastCol _ lastCol max: index.! !

!SimpleTextState methodsFor: 'accessing'!
bgRuns

	^bgRuns! !

!SimpleTextState methodsFor: 'accessing'!
changed

	^changed! !

!SimpleTextState methodsFor: 'accessing'!
changed: aBoolean

	changed _ aBoolean! !

!SimpleTextState methodsFor: 'accessing'!
cursorCol: x

	cursorCol _ x.
	changed _ true! !

!SimpleTextState methodsFor: 'accessing'!
cursorColumn

	^cursorCol! !

!SimpleTextState methodsFor: 'accessing'!
deleteCharAt: index
	"Delete the character at index, moving anything to the right of it left one column."

	index to: stringSize - 1 do: [:i |
		string at: i put: (string at: i + 1).
		fgRuns at: i put: (fgRuns at: i + 1).
		bgRuns at: i put: (bgRuns at: i + 1).
		emRuns at: i put: (emRuns at: i + 1)].
	string at: stringSize put: $ .
	lastCol _ lastCol - 1 max: 0.
	changed _ true! !

!SimpleTextState methodsFor: 'accessing'!
emRuns

	^emRuns! !

!SimpleTextState methodsFor: 'accessing'!
fgRuns

	^fgRuns! !

!SimpleTextState methodsFor: 'accessing'!
foreground: fbIndex

	1 to: stringSize do: [:i | self foregroundAt: i put: fbIndex]! !

!SimpleTextState methodsFor: 'accessing'!
foregroundAt: index put: c

	(fgRuns at: index) ~~ c
		ifTrue:
			[fgRuns at: index put: c.
			 changed _ true]! !

!SimpleTextState methodsFor: 'accessing'!
from: start to: stop put: char fg: fg bg: bg em: em

	string from: start to: stop put: char.
	fgRuns from: start to: stop put: fg.
	bgRuns from: start to: stop put: bg.
	emRuns from: start to: stop put: em.
	changed _ true! !

!SimpleTextState methodsFor: 'accessing'!
insertAt: index

	stringSize - 1 to: index by: -1 do: [:i |
		string at: i + 1 put: (string at: i).
		fgRuns at: i + 1 put: (fgRuns at: i).
		bgRuns at: i + 1 put: (bgRuns at: i).
		emRuns at: i + 1 put: (emRuns at: i)].
	lastCol _ lastCol + 1 min: stringSize max: index.
	changed _ true! !

!SimpleTextState methodsFor: 'accessing'!
lastColumn
	"Answer the rightmost column into which a character has been explicitly written."

	^lastCol! !

!SimpleTextState methodsFor: 'accessing'!
lastColumn: col
	"Somebody has deleted everythig from col onwards."

	lastCol _ col! !

!SimpleTextState methodsFor: 'accessing'!
selection
	"Answer the selection range for this line."

	^selection! !

!SimpleTextState methodsFor: 'accessing'!
setWidth: width

	string size < width
		ifTrue: [self string: (string forceTo: width paddingWith: $ )]
		ifFalse: [string size > width
			ifTrue: [self from: width + 1 to: string size  put: $  fg: 0 bg: 7 em: 0]].
	stringSize _ width.
	self findLastColumn.! !

!SimpleTextState methodsFor: 'accessing'!
string

	^string! !

!SimpleTextState methodsFor: 'accessing'!
string: aString
	"Replace the receiver's string with aString.  If the receiver changes width then also modify the colours and emphasis retaining the overlapping portions and extending with default colours and emphasis, and then update the geometry.  Reset lastCol to be the index of the last non-whitespace in aString."

	| oldSize newSize |
	oldSize _ string size.
	newSize _ aString size.
	string _ aString.
	oldSize < newSize
		ifTrue:
			[fgRuns _ fgRuns forceTo: newSize paddingWith: 0.
			 bgRuns _ bgRuns forceTo: newSize paddingWith: 7.
			 emRuns _ emRuns forceTo: newSize paddingWith: 0]
		ifFalse:
			[fgRuns from: newSize + 1 to: oldSize put: 0.
			 bgRuns from: newSize + 1 to: oldSize put: 7.
			 emRuns from: newSize + 1 to: oldSize put: 0].
	cursorCol _ cursorCol min: newSize.
	stringSize _ newSize.
	self findLastColumn.
	selection _ nil! !

!SimpleTextState methodsFor: 'accessing'!
stringSize

	^stringSize! !

!SimpleTextState methodsFor: 'copying'!
copy

	^self deepCopy! !

!SimpleTextState methodsFor: 'selection'!
appendSelectionTo: aStream

	selection isNil ifTrue: [^self].	"no selection"
	selection first > lastCol ifTrue: [^aStream cr].	"only the end of line is selected"
	selection first to: (selection last min: lastCol) do: [:i | aStream nextPut: (string at: i)].	"line contents are selected"
	selection last > lastCol ifTrue: [aStream cr].	"end of line is included in selection"! !

!SimpleTextState methodsFor: 'selection'!
clearSelection

	selection isNil ifTrue: [^self].
	selection first to: selection last do: [:i | emRuns at: i put: ((emRuns at: i) bitXor: 64)].
	selection _ nil.
	changed _ true! !

!SimpleTextState methodsFor: 'selection'!
findFirstInClass: charClasses from: start
	"Find the index of the leftmost character in the sequence of characters beginning at start that all belong to the same class in charClasses."

	| charClass |
	charClass _ charClasses at: (string at: start) asciiValue + 1.
	start - 1 to: 1 by: -1 do: [ :i | (charClasses at: (string at: i) asciiValue + 1) == charClass ifFalse: [^i + 1]].
	^1.! !

!SimpleTextState methodsFor: 'selection'!
findLastInClass: charClasses from: start
	"Find the index of the rightmost character in the sequence of characters beginning at start that all belong to the same class in charClasses."

	| charClass |
	charClass _ charClasses at: (string at: start) asciiValue + 1.
	start + 1 to: lastCol do: [ :i | (charClasses at: (string at: i) asciiValue + 1) == charClass ifFalse: [^i - 1]].
	^lastCol.! !

!SimpleTextState methodsFor: 'selection'!
selectFrom: left to: right

	selection isNil ifFalse: [self clearSelection].
	selection _ Array with: left with: right.
	left to: right do: [:i | emRuns at: i put: ((emRuns at: i) bitXor: 64)].
	changed _ true! !

!SimpleTextState methodsFor: 'selection'!
selectionSpansColumn: index
	"Answer whether index is inside the current selection range."

	^selection notNil and: [index >= selection first and: [index <= selection last]]! !

!SimpleTextState methodsFor: 'private'!
findLastColumn

	stringSize to: 1 by: -1 do: [ :i | (string at: i) == $  ifFalse: [^lastCol _ i]].
	^lastCol _ 0.! !


!SimpleTextState class methodsFor: 'instance creation'!
new

	^super new initialize! !

!SimpleTextState class methodsFor: 'instance creation'!
new: size

	^self string: (String new: size withAll: $ )! !

!SimpleTextState class methodsFor: 'instance creation'!
string: aString

	^super new initialize: aString! !


!StatefulProtocol methodsFor: 'accessing'!
client: anObject

	client _ anObject! !

!StatefulProtocol methodsFor: 'accessing'!
initialState: stateNode

	currentState _ stateNode.
	self client: self! !

!StatefulProtocol methodsFor: 'accessing'!
state

	^currentState! !

!StatefulProtocol methodsFor: 'protocol'!
upcall: anObject

	currentState _ (currentState transitionAt: anObject)
		transitionFrom: currentState for: client with: anObject! !


!StatefulProtocol class methodsFor: 'instance creation'!
initialState: stateNode

	^self new initialState: stateNode! !

!StatefulProtocol class methodsFor: 'instance creation'!
initialState: stateNode client: aClient

	^self new initialState: stateNode; client: aClient! !


!StatefulProtocolDescription methodsFor: 'initialize-release'!
initialState: stateName

	initialState _ stateName! !

!StatefulProtocolDescription methodsFor: 'initialize-release'!
newState: rule

	^self newState: rule key default: rule value! !

!StatefulProtocolDescription methodsFor: 'initialize-release'!
newState: stateName default: transition

	^self at: stateName put: (ProtocolState name: stateName default: transition)! !

!StatefulProtocolDescription methodsFor: 'printing'!
printElementsOn: aStream

	aStream nextPutAll: '(initial: ' , initialState printString , ' states:'.
	self keysDo: [:key | aStream space.  key printOn: aStream].
	aStream nextPut: $)! !

!StatefulProtocolDescription methodsFor: 'compiling'!
compile
	"Compile my symbolic representation into a cyclic DAG and answer the root node"

	| edge |
	self valuesDo: [:state |
		state defaultTransition: (self resolve: state default).
		state keysDo: [:key |
			edge _ state at: key.
			state transitionAt: key put: (self resolve: edge)]].
	
	^self at: initialState! !

!StatefulProtocolDescription methodsFor: 'compiling'!
resolve: edge

	| target action |
	target _ edge state.
	action _ edge action.
	target _ (self includesKey: target)
		ifTrue: [self at: target]
		ifFalse: [target isNil
					ifTrue: [nil]
					ifFalse: [self error: 'unknown target state ' , edge printString]].
	^ProtocolStateTransition action: action state: target! !


!StatefulProtocolDescription class methodsFor: 'instance creation'!
initialState: stateName

	^self new initialState: stateName! !

!StatefulProtocolDescription class methodsFor: 'examples'!
example
	"A state machine that recognises occurrences of 'x' 'xy' and 'xy[digits...]z' in a stream of characters.  Note: this is used by StateMachineTester, so don't modify it.  See StateMachineTester class>>test for an example of use."
	"StatefulProtocolDescription example"

	| desc |
	desc _ self new.
	(desc newState: #initial -> (#echo: -> #initial)) add: $x -> (nil -> #statex).
	(desc newState: #statex -> (#echox: -> #initial)) add: $y -> (#initPrefix: -> #statexy).
	(desc newState: #statexy -> (#echoxy: -> #initial))
		add: $z -> (#echoxyz: -> #initial);
		addAll: '0123456789' -> (#addPrefix: -> nil).
	desc initialState: #initial.
	^desc! !

!StatefulProtocolDescription class methodsFor: 'examples'!
example2
	"StatefulProtocolDescription example2 explore"

	^self example compile! !

!StatefulProtocolDescription class methodsFor: 'examples'!
example3		"Note: this example should pop up an error notifier during compilation"

	"StatefulProtocolDescription example3 compile"

	| desc |
	desc _ self new.
	(desc newState: #initial -> (#echo: -> #initial)) add: $x -> (nil -> #statex).
	(desc newState: #statex -> (#echox: -> #initial)) add: $y -> (nil -> #statexy).
	(desc newState: #statexy -> (#echoxy: -> #initial)) add: $z -> (#echoxy: -> #statexyz).
	desc initialState: #initial.
	^desc! !


!StatefulProtocolTester methodsFor: 'state transitions'!
step: anObject
	Transcript cr;
		print: currentState name;
		nextPutAll: ' step: ';
		print: anObject;
		nextPutAll: ' -> ';
		endEntry.
	self upcall: anObject.! !

!StatefulProtocolTester methodsFor: 'actions'!
addPrefix: anObject

	prefix _ prefix * 10 + anObject asInteger - 48! !

!StatefulProtocolTester methodsFor: 'actions'!
echo: anObject

	Transcript show: anObject printString! !

!StatefulProtocolTester methodsFor: 'actions'!
echox: anObject

	Transcript show: ' <saw X> ' , anObject printString! !

!StatefulProtocolTester methodsFor: 'actions'!
echoxy: anObject

	Transcript show: ' <saw XY> ' , anObject printString! !

!StatefulProtocolTester methodsFor: 'actions'!
echoxyz: anObject

	Transcript show: ' <saw XYZ prefix ' , prefix printString , ' > ' , anObject printString! !

!StatefulProtocolTester methodsFor: 'actions'!
initPrefix: anObject

	prefix _ 0! !


!StatefulProtocolTester class methodsFor: 'examples'!
test
	"StatefulProtocolTester test"

	| sm input |
	sm _ self initialState: (StatefulProtocolDescription example compile).
	sm client: sm.
	input _ '1x2xx3xxx4y5xy6yy7xyx8xyy9xyz10zyx'.
	Transcript cr; show: 'input is ' , input printString ; cr.
	'1x2xx3xxx4y5xy6yy7xyx8xyy9xyz10xy42zzyx' do: [: c | sm step: c].
	Transcript cr; show: ' final state is ' , sm state name printString; cr.! !


!StatefulProtocolTester2 methodsFor: 'initialize-release'!
reset

	e _ x _ xy _ xyz _ 0! !

!StatefulProtocolTester2 methodsFor: 'actions'!
echo: anObject

	e _ e + 1! !

!StatefulProtocolTester2 methodsFor: 'actions'!
echox: anObject

	x _ x + 1! !

!StatefulProtocolTester2 methodsFor: 'actions'!
echoxy: anObject

	xy _ xy + 1! !

!StatefulProtocolTester2 methodsFor: 'actions'!
echoxyz: anObject

	xyz _ xyz + 1! !

!StatefulProtocolTester2 methodsFor: 'printing'!
printOn: aStream

	aStream cr; nextPutAll: 'saw ',
		e printString, ' unmatched characters, ',
		x printString, ' x, ',
		xy printString, ' xy, ',
		xyz printString, ' xyz'.! !


!StatefulProtocolTester2 class methodsFor: 'examples'!
test
	"A version of StatefulProtocolTester that measures throughput (in transitions per second)."

	"StatefulProtocolTester2 test"

	| sm input stream size time |
	sm _ self initialState: (StatefulProtocolDescription example compile).
	sm client: sm.
	input _ '1x2xx3xxx4y5xy6yy7xyx8xyy9xyz10zyx'.
	Transcript cr; show: 'input is ' , input printString ; cr.
	stream _ WriteStream on: input.
	[stream contents size < 100000] whileTrue: [stream nextPutAll: input].
	Transcript show: 'size is ' , (size _ stream contents size) printString; cr.
	input _ ReadStream on: stream contents.
	time _ Time millisecondsToRun: [sm reset; upcallAll: input].
	Transcript show: sm printString , ' in ' , time printString , 'ms'; cr.
	Transcript show: (size / time * 1000) asInteger printString,
		' state transitions per second'! !


!StrikeFont methodsFor: 'testing'!
isMonospaced
	| widths |
	widths _ ((0 to: 255) collect: [ :n | self widthOf: (Character value: n) ]) asBag.
	^(widths sortedElements reject: [ :a | a key == 0 ]) size < 3! !


!StrikeFont class methodsFor: 'accessing'!
monospacedFamilyNames
	| retval |
	retval _ Set new.
	(TextConstants select: [ :ea | ea isKindOf: TextStyle ]) do: [ :family |
		retval addAll: ((family fonts select: [ :font | font isMonospaced ]) collect: [ :font | font familyName asSymbol ])
	].
	^retval! !


!TeletypeMorph methodsFor: 'initialize-release'!
initialize

	^self initialize: 80@24! !

!TeletypeMorph methodsFor: 'initialize-release'!
initialize: size

	super initialize.
	borderWidth _ 2.
	color _ Color white.
	inset _ 2.
	trackingSelection _ false.
	useScrollbar _ false.
	self
		initializeTeletype: size;
		initializeContent;
		initializeScrollbar;
		extent: self preferredExtent! !

!TeletypeMorph methodsFor: 'initialize-release'!
initializeContent

	| morphs |
	morphs _ OrderedCollection new.
	rows timesRepeat: [morphs addLast: ((SimpleTextMorph contents: (lines addLast: self newLine)) cursorColour: cursorColour)].
	self addAllMorphs: morphs.
	topLine _ 1.
	bottomLine _ rows.
	x _ y _ 1.
	self banner do: [:c | self upcall: c asInteger]! !

!TeletypeMorph methodsFor: 'initialize-release'!
initializeScrollbar

	scrollFlop _ (Preferences valueOfFlag: #inboardScrollbars) not.
	scrollRight _ (Preferences valueOfFlag: #scrollBarsOnRight).
	useScrollbar & scrollFlop not ifTrue: [self showScrollbar]! !

!TeletypeMorph methodsFor: 'initialize-release'!
initializeTabs

	tabs _ Array new: cols withAll: false.
	1 to: cols by: 8 do: [:i | tabs at: i put: true]! !

!TeletypeMorph methodsFor: 'initialize-release'!
initializeTeletype: size
	"Initialize the default behaviour: dumb terminal with local echo and default xterm VT options."

	font _ (TextConstants at: (SimpleTextMorph defaultFont)) defaultFont.
	pitch _ font widthOf: $m.
	skip _ font height.
	cols _ size x.  rows _ size y.
	lines _ OrderedCollection new.
	savedLines _ 0.
	savedLineLimit _ SavedLineLimit.
	displayStart _ 0.
	x _ 1.  y _ 1.
	fg _ 0.  bg _ 7.  em _ 0.
	rv _ false.  ec _ false.
	session _ nil.
	self initializeTabs.
	self initializeTerminalModes.
	"Default low protocol: local echo"
	down _ (ProtocolAdaptor new localEcho up: self).
	showCursor _ true.
	running _ false.
	autoFlush _ 0.
	steps _ 0.
	altScreenActive _ false.
	altScreenColours _ false.
	hasFocus _ true.
	selectionStart _ selectionEnd _ nil.
	selectionActive _ false.
	selection _ ''.
	mouseControlsSelection _ MouseControlsSelection.
	keyboardControlsSelection _ KeyboardControlsSelection.
	scrollOnInput _ false.
	scrollOnOutput _ true.
	allow132 _ true.
	characterClasses _ CharClass copy.
	cursorColour _ nil.! !

!TeletypeMorph methodsFor: 'initialize-release'!
initializeTerminalModes
	"Initialize the default behaviour: dumb terminal with local echo and standard xterm VT option settings."

	autoWrap _ true.
	reverseWrap _ autoLinefeed _ autoCR _ relativeOrigin _ insertMode _ false.
	showCursor _ true.
	smoothScroll _ false.
	metaSendsEscape _ true.
	deleteIsDel _ false.
	altScreenSwitch _ true.
	reverseVideo _ false.! !

!TeletypeMorph methodsFor: 'initialize-release'!
openInWorld

	self currentHand newKeyboardFocus: nil.
	super openInWorld.
! !

!TeletypeMorph methodsFor: 'initialize-release'!
session: aSession

	session _ aSession! !

!TeletypeMorph methodsFor: 'initialize-release'!
setWindow: aWindow

	systemWindow _ aWindow! !

!TeletypeMorph methodsFor: 'accessing'!
activeColumn

	^x! !

!TeletypeMorph methodsFor: 'accessing'!
activeColumn: c

	x _ c min: cols.
	self showCursor.! !

!TeletypeMorph methodsFor: 'accessing'!
bufferState
	"Answer an opaque representation of the current state of the buffer contents."

	| theLines state |
	self clearSelection.
	theLines _ OrderedCollection new.
	self linesDo: [:line | theLines addLast: line copy].
	state _ Array with: theLines asArray with: rv with: altScreenActive with: x with: y with: cursorColour.
	altScreenActive _ true.
	^state! !

!TeletypeMorph methodsFor: 'accessing'!
bufferState: state
	"Restore the buffer contents to a previously saved state."

	| theLines nRows |
	altScreenSwitch ifFalse: [^self].
	self clearSelection; clearCursor.
	theLines _ state at: 1.
	rv _ state at: 2.
	altScreenActive _ state at: 3.
	"Ensure we have sufficient lines in the display."
	[lines size < theLines size]
		whileTrue:
			[lines addLast: (SimpleTextState new: cols).
			 self addMorphBack: (SimpleTextMorph contents: lines last)].
	nRows _ rows min: theLines size.
	1 to: nRows do: [ :i |
		(submorphs at: i)
			lineState:
			(self displayLineAt: i put:
				((theLines at: i) setWidth: cols))].
	nRows + 1 to: rows do: [:i | self clearLine: i from: 1 to: cols].
	submorphs from: 1 to: rows do: [ :m | m rv: (rv xor: reverseVideo)].
	x _ (state at: 4) min: cols max: 1.
	y _ (state at: 5) min: rows max: 1.
	cursorColour _ state at: 6.
	self showCursor; linesChanged; changed! !

!TeletypeMorph methodsFor: 'accessing'!
characterClass

	^CharClass! !

!TeletypeMorph methodsFor: 'accessing'!
columns

	^cols! !

!TeletypeMorph methodsFor: 'accessing'!
deleteIsDel

	^deleteIsDel! !

!TeletypeMorph methodsFor: 'accessing'!
deleteIsDel: aBoolean

	deleteIsDel _ aBoolean! !

!TeletypeMorph methodsFor: 'accessing'!
graphicsState
	"Answer an opaque representation of the current character attributes."

	^Array with: fg with: bg with: em with: rv! !

!TeletypeMorph methodsFor: 'accessing'!
graphicsState: gs
	"Restore the current character attributes.  (See #graphicsState.)"

	fg _ gs at: 1.
	bg _ gs at: 2.
	em _ gs at: 3! !

!TeletypeMorph methodsFor: 'accessing'!
hasFocus

	^hasFocus! !

!TeletypeMorph methodsFor: 'accessing'!
metaSendsEscape

	^metaSendsEscape! !

!TeletypeMorph methodsFor: 'accessing'!
pitch

	^pitch! !

!TeletypeMorph methodsFor: 'accessing'!
rows

	^rows! !

!TeletypeMorph methodsFor: 'accessing'!
rv: aBoolean
	"Set the programmed reverse video flag.  Not to be confused with reverseVideo, which is a user preference that inverts the sense of the programmed change."

	rv == aBoolean ifTrue: [^self].
	rv _ aBoolean..
	submorphs from: 1 to: rows do: [ :m | m rv: (rv xor: reverseVideo)].
	self changed! !

!TeletypeMorph methodsFor: 'accessing'!
skip

	^skip! !

!TeletypeMorph methodsFor: 'testing'!
isCollapsed

	^(systemWindow notNil) and: [systemWindow isCollapsed]! !

!TeletypeMorph methodsFor: 'events'!
handlesKeyboard: evt
	"Answer whether we're interested in keyboard events."

	^true "hasFocus or: [super handlesKeyboard: evt]"! !

!TeletypeMorph methodsFor: 'events'!
handlesMouseDown: evt
	"Answer whether we're interested in mouse events."

	^true "self isConnected and: [hasFocus or: [super handlesMouseDown: evt]]"! !

!TeletypeMorph methodsFor: 'events'!
handlesMouseOver: evt

	^true "hasFocus or: [super handlesMouseOver: evt]"! !

!TeletypeMorph methodsFor: 'events'!
keyStroke: evt
	"Receive a character from the keyboard."

	| char |
	scrollOnInput ifTrue: [self pageEnd].
	char _ evt keyCharacter asciiValue.
	evt controlKeyPressed
		ifFalse:
			[char == 1 ifTrue: [^self pageHome].
			 char == 4 ifTrue: [^self pageEnd].
			 char == 11 ifTrue: [^self pageUp: rows // 2].
			 char == 12 ifTrue: [^self pageDown: rows // 2]].
	(keyboardControlsSelection and: [evt commandKeyPressed])
		ifTrue:
			[evt keyCharacter == $c ifTrue: [^self copySelection].
			 evt keyCharacter == $v ifTrue: [^self sendSelection]].
	(metaSendsEscape and: [evt commandKeyPressed])
		ifTrue: [down downcall: Character escape asciiValue].
	"Cursor keys clash with control keys: differentiate by sending 128+cursorKeyCode."
	(char == 8 & deleteIsDel and: [evt controlKeyPressed not]) ifTrue: [char _ 127].
	(char < 32 and: [evt controlKeyPressed not]) ifTrue: [char _ char + 128].
	down downcall: char.
	evt wasHandled: true.! !

!TeletypeMorph methodsFor: 'events'!
keyboardFocusChange: aBoolean

	hasFocus _ aBoolean! !

!TeletypeMorph methodsFor: 'events'!
lock
	"We're losing keyboard focus."

	super lock.
	hasFocus _ false.
	self changed.! !

!TeletypeMorph methodsFor: 'events'!
mouseDown: evt
	"A mouse button has been pressed."

"	evt printString displayAt: 10@200.
"
	evt hand newKeyboardFocus: self.

	"Yellow button is menu (or selection send when in xterm mode)."
	(evt yellowButtonChanged)
		ifTrue:
			[(mouseControlsSelection and: [evt anyModifierKeyPressed not])
				ifTrue: [self sendSelection]
				ifFalse: [(systemWindow isKindOf: TeletypeWindow)
					ifTrue: [systemWindow offerWindowMenu]
					ifFalse: [self offerVTMenu]].
			 ^super mouseDown: evt].

	"Red button is selection start (or selection extend when shifted in Squeak mode)."
	(evt redButtonChanged)
		ifTrue:
			[evt shiftPressed
				ifTrue: ["mouseControlsSelection not and:" self extendSelection: evt position]
				ifFalse: [self startSelection: evt position].
			 ^super mouseDown: evt].

	"Blue button is selection extend when in xterm mode."
	(mouseControlsSelection and: [evt blueButtonChanged])
		ifTrue:
			[self extendSelection: evt position.
			 ^super mouseDown: evt].

	super mouseDown: evt.! !

!TeletypeMorph methodsFor: 'events'!
mouseEnter: evt
	"The pointer just entered the window."

	TextCursor beCursor.
	useScrollbar & scrollFlop ifTrue: [self showScrollbar].
	super mouseEnter: evt! !

!TeletypeMorph methodsFor: 'events'!
mouseLeave: evt
	"The cursor just left the window."

	Cursor normal show.
	useScrollbar & scrollFlop ifTrue: [self hideScrollbar].
	super mouseLeave: evt! !

!TeletypeMorph methodsFor: 'events'!
mouseMove: evt
	"The mouse is moving inside the window."

"	evt printString displayAt: 10@220.
"
	evt redButtonPressed ifTrue: [self trackSelection: evt position].
	super mouseMove: evt! !

!TeletypeMorph methodsFor: 'events'!
mouseUp: evt
	"A mouse button has been released."

"	evt printString displayAt: 10@240.
"
	evt redButtonChanged ifTrue: [self endSelection: evt position].
	evt wasHandled: true! !

!TeletypeMorph methodsFor: 'events'!
unlock
	"We're acquiring keyboard focus."

	super unlock.
	hasFocus _ true.
	self changed.! !

!TeletypeMorph methodsFor: 'events'!
wouldAcceptKeyboardFocus
	"Of course we would."

	^true! !

!TeletypeMorph methodsFor: 'selection'!
clearSelection
	"Remove the visual representation of the selection region.  Saved selection text is unaffacted."

	selectionActive ifFalse: [^self].
	lines do: [:line | line clearSelection].
	selectionActive _ false.
	"self changed"! !

!TeletypeMorph methodsFor: 'selection'!
copySelection
	"Copy the currently selected text to the clipboard."

	Clipboard clipboardText: selection! !

!TeletypeMorph methodsFor: 'selection'!
endSelection: screenPosition
	"Mouse selection has just finished.  Stop tracking and, iff the mouse moved since selection start, compute and remember the new selection text."

	self stopSteppingSelector: #trackSelection.
	self showCursor; changed.
	selectionEnd isNil ifTrue: [^nil].
	self saveSelection.
	screenPosition = mousePosition ifFalse: [selectionEnd _ nil]! !

!TeletypeMorph methodsFor: 'selection'!
extendSelection: screenPosition
	"Extend the current selection through screenPosition."

	selectionStart isNil ifFalse: [self trackSelection: screenPosition]! !

!TeletypeMorph methodsFor: 'selection'!
getSelectionRegion
	"Answer a Rectangle representing the current selection area in character coordinates.  Note that the origin may be to the right of the corner."

	| start end tmp |
	(start _ selectionStart) y > (end _ selectionEnd) y ifTrue: [start _ selectionEnd.  end _ selectionStart].
	(start y == end y and: [start x > end x]) ifTrue: [tmp _ start.  start _ end.  end _ tmp].
	"start now guaranteed to be before end in screen"
	"we don't include the character under selectionStart"
	end _ end - (1@0).
	^Rectangle origin: start corner: end! !

!TeletypeMorph methodsFor: 'selection'!
highlightSelection
	"The selection region has changed.  Update the visual representation."

	| region |
	region _ self getSelectionRegion.
	lines do: [ :line | line clearSelection].
	region height == 0		"single line"
		ifTrue:
			[(lines at: region top) selectFrom: region left to: region right]
		ifFalse:
			[(lines at: region top) selectFrom: region left to: cols.
			 lines from: region top + 1 to: region bottom - 1 do: [:line | line selectFrom: 1 to: cols].
			 (lines at: region bottom) selectFrom: 1 to: region right].
	selectionActive _ true.
	self changed! !

!TeletypeMorph methodsFor: 'selection'!
saveSelection
	"A new selection has been made.  Compute and remember the selection text."

	| stream region |
	region _ self getSelectionRegion.
	stream _ WriteStream on: String new.
	lines from: region top to: region bottom do: [:line | line appendSelectionTo: stream].
	selection _ stream contents.
	mouseControlsSelection ifTrue: [Clipboard clipboardText: selection].! !

!TeletypeMorph methodsFor: 'selection'!
selectLine: screenPosition
	"Triple click.  Select the line surrounding the cursor, including the end of line, and save the selection text."

	| pos |
"
	'select line   ' displayAt: 10@130.
"
	pos _ self selectionPositionAt: screenPosition.
	selectionStart _ 1 @ pos y.
	selectionEnd _ cols + 1 @ pos y.
	self highlightSelection; saveSelection.
	selectionEnd _ nil.
	mousePosition _ nil.! !

!TeletypeMorph methodsFor: 'selection'!
selectWord: screenPosition
	"Double click.  Select the word surrounding the cursor according to the current char class and save the selection text."

	| pos line left right |
"
	'select word   ' displayAt: 10@130.
"
	pos _ self selectionPositionAt: screenPosition.
	line _ lines at: pos y.
	left _ line findFirstInClass: self characterClass from: (pos x min: cols).
	right _ line findLastInClass: self characterClass from: (pos x min: cols).
	selectionStart _ left @ pos y.
	selectionEnd _ right + 1 @ pos y.
	right < left
		ifTrue: [self clearSelection]
		ifFalse: [self highlightSelection; saveSelection]! !

!TeletypeMorph methodsFor: 'selection'!
selectionPositionAt: screenPosition
	"Answer a Point in character coordinates corresponding to the given position in screen coordinates.  If screenPosition is above the window, try to scroll up before answering the first character in the window.  If screenPosition is below the window, try to scroll down before answering one character right of the last character in the window."

	| pos |
	screenPosition y < (self submorphs at: 1) bounds top
		ifTrue:
			[self pageUp: (rows // 8 max: 1).
			 ^1 @ (displayStart + 1)].
	screenPosition y > (self submorphs at: rows) bounds bottom
		ifTrue:
			[self pageDown: (rows // 8 max: 1).
			 ^(cols + 1) @ (displayStart + rows)].
	1 to: rows do: [:i
		| (pos _ (self submorphs at: i) selectionColumnAt: screenPosition) isNil
			ifFalse: [^pos @ (displayStart + i)]].
	^nil! !

!TeletypeMorph methodsFor: 'selection'!
sendSelection
	"Send the clipboard text to the application."

	down downcallAll: Clipboard clipboardText asString asByteArray! !

!TeletypeMorph methodsFor: 'selection'!
startSelection: screenPosition
	"Mouse selection has begun.  If this is a double click (mouse hasn't moved since last click and selectionEnd isNil) then select the word under the pointer.  If this is a triple click (mouse hasn't moved and selectionEnd notNil after prior word selection) then select the line under the pointer.  Otherwise clear the current selectionStart and begin tracking."

	| start |
	self hideCursor; changed.
	mousePosition = screenPosition
		ifTrue:
			[^selectionEnd isNil
				ifTrue: [self selectWord: screenPosition]
				ifFalse: [self selectLine: screenPosition]].
"
	'mouse position ' , mousePosition printString,
	' screen position ', screenPosition printString, 
	' selectionEnd ', selectionEnd printString, 
	'  ' displayAt: 10@150.
"
	mousePosition _ screenPosition.
	selectionEnd _ nil.

	start _ self selectionPositionAt: screenPosition.
	self clearSelection.
	selectionStart _ start.
"
	'selection begin ', selectionStart printString, '     ' displayAt: 10@10
"! !

!TeletypeMorph methodsFor: 'selection'!
trackSelection
	"The mouse is down during selection tracking.  Update the visual representation of the selected region."

	| pos |
	(pos _ self selectionPositionAt: Sensor cursorPoint) isNil
		ifFalse:
			[selectionEnd _ pos.
			 self highlightSelection]! !

!TeletypeMorph methodsFor: 'selection'!
trackSelection: screenPosition
	"The mouse moved during selection tracking.  Update the visual representation of the selected region."

	(trackingSelection or: [(self selectionPositionAt: screenPosition) isNil])
		ifFalse: [self
				startStepping: #trackSelection
				at: Time millisecondClockValue
				arguments: #()
				stepTime: 100]! !

!TeletypeMorph methodsFor: 'geometry'!
extent: newExtent
	"We're being allocated real estate from above (initial placement or manual resize).  Adjust the screen size accordingly."

	| layoutBounds textBounds nCols nRows org ext lineSkip |
	super extent: newExtent.
	layoutBounds _ self layoutBounds.
	textBounds _ self textBounds: layoutBounds.
	nCols _ textBounds width // pitch.
	nRows _ textBounds height // skip.
	self hideScrollbar; initTextBounds: textBounds width: nCols height: nRows.
	org _ textBounds topLeft.
	ext _ (cols * pitch) @ skip.
	lineSkip _ 0 @ skip.
	submorphs doWithIndex: [:m :i |
		m bounds: (org extent: ext).
		org _ org translateBy: lineSkip].
	(useScrollbar and: [scrollFlop not]) ifTrue: [self showScrollbar].! !

!TeletypeMorph methodsFor: 'geometry'!
hideScrollbar
	"Remove the scrollbar from the window."

	scroll notNil
		ifTrue:
			[scroll delete.
			 scroll _ nil]! !

!TeletypeMorph methodsFor: 'geometry'!
initScrollbar: frame
	"Initialize the scrollbar to fit in/around the given frame."

	| width extent origin |
	width _ self scrollbarWidth.
	scrollFlop
		ifFalse:
			[extent _ (width) @ (frame height).
			 origin _ scrollRight
				ifFalse: [frame origin]
				ifTrue: [(frame right - width) @ (frame top)]]
		ifTrue:
			[extent _ (width + borderWidth) @ (frame height + (borderWidth * 2)).
			 origin _ scrollRight
				ifFalse: [(frame left - width - borderWidth) @ (frame top - borderWidth)]
				ifTrue: [(frame right) @ (frame top - borderWidth)]].
	scroll bounds: (origin extent: extent)! !

!TeletypeMorph methodsFor: 'geometry'!
initTextBounds: textBounds width: nCols height: nRows
	"This is a geometry change imposed from outside (either initial placement or manual resizing).  We honour it without attempting to fix the geometry of our owner."

	| r morphs morph |
	(nCols == cols and: [nRows == rows]) ifTrue: [^self].
	morphs _ OrderedCollection withAll: submorphs.	"copy".
	self clearSelection; hideCursor; removeAllMorphs.
	cols _ nCols max: 1.
	x _ x min: cols.
	lines do: [ :line | line setWidth: cols].
	r _ nRows max: 1.
	[rows < r]
		whileTrue:
			[displayStart > 0
				ifTrue:
					["suck last saved line back down into the screen"
					 displayStart _ displayStart - 1.
					 savedLines _ savedLines - 1.
					 morphs addFirst: (SimpleTextMorph contents: (self displayLineAt: 1)).
					 y _ y + 1]
				ifFalse:
					["add a new empty line at the bottom of the screen"
					 morph _ SimpleTextMorph contents: (lines addLast: (SimpleTextState new: cols)).
					 morphs addLast: morph].
			 rows _ rows + 1].
	[rows > r]
		whileTrue:
			[rows _ rows - 1.
			 savedLines _ savedLines + 1.
			 displayStart _ displayStart + 1.
			 morphs removeLast.
			 y _ y - 1 max: 1].
	self
		addAllMorphs: morphs;
		showCursor;
		doSoftReset;
		initializeTabs;
		reportSizeToSession;
		linesChanged.
	"morphic explodes if we continue before making absolutely sure the window is redrawn..."
	"(running and: [self world notNil]) ifTrue: [self world doOneCycle]"! !

!TeletypeMorph methodsFor: 'geometry'!
initialExtent

	self flag: #ikp. "can this can go away?"
	^self preferredExtent! !

!TeletypeMorph methodsFor: 'geometry'!
preferredExtent
	"Answer the extent that we would be given in an ideal world (no pun intended).  This is just the amout of space we need to display our contents, and no more."

	| w h s |
	s _ (useScrollbar and: [scrollFlop not]) ifTrue: [self scrollbarWidth] ifFalse: [0].
	w _ borderWidth + s + inset + (cols * pitch) + inset + borderWidth.
	h _ borderWidth + inset + (rows * skip) + inset + borderWidth.
	^w@h! !

!TeletypeMorph methodsFor: 'geometry'!
scrollbarWidth

	^ScrollPane new scrollbarWidth! !

!TeletypeMorph methodsFor: 'geometry'!
setWidth: nCols height: nRows
	"This is a programmed geometry change.  We try to honour it by figuring out the corresponding geometry change required in our owner in order to acheive the given number of cols and rows.  The actual change takes place on the flip side, when our owner sends down our new extent."

	| flak |
	(cols == nCols and: [rows == nRows]) ifTrue: [^self].
	flak _ systemWindow isNil ifTrue: [0] ifFalse: [systemWindow fullBounds extent - self textBounds extent].
	"self changed; sync."
	(systemWindow isNil ifTrue: [self] ifFalse: [systemWindow])
		extent: (pitch * nCols) @ (skip * nRows) + flak.
	"self sync."! !

!TeletypeMorph methodsFor: 'geometry'!
showScrollbar
	"Add a scrollbar to the window."

	scroll isNil
		ifTrue:
			[scroll _ ScrollBar new model: self slotName: 'scrollbar'; initializeEmbedded: scrollFlop not.
			 self
				addMorphBack: scroll;
				initScrollbar: self layoutBounds;
				updateScrollbar]! !

!TeletypeMorph methodsFor: 'geometry'!
textBounds
	"Answer just the bounds of the text -- excluding border, scroll and inset."

	^self textBounds: self layoutBounds! !

!TeletypeMorph methodsFor: 'geometry'!
textBounds: outer
	"Answer just the bounds of the text -- excluding border, scroll and inset."

	| width left right inner |
	left _ right _ 0.
	(useScrollbar & scrollFlop not)
		ifTrue:
			[width _ self scrollbarWidth.
			 scrollRight ifTrue: [right _ width] ifFalse: [left _ width]].
	inner _ outer insetBy: inset.
	^(inner left + left) @ (inner top) corner: (inner right - right) @ (inner bottom)! !

!TeletypeMorph methodsFor: 'character writing'!
fillScreen: char

	self
		clearSelection;
		linesDo: [:line | line atAllPut: char fg: fg bg: bg em: em]! !

!TeletypeMorph methodsFor: 'character writing'!
put: aChar

	scrollOnOutput ifTrue: [self pageEnd].
	(insertMode and: [x < cols]) ifTrue: [(self protectSelection; currentLine) insertAt: x].
	(aChar == 13 & autoLinefeed or: [aChar == 10 & autoCR])
		ifTrue: [self newline]
		ifFalse: [self putNormal: aChar; cursorRight: 1 wrapping: true]! !

!TeletypeMorph methodsFor: 'character writing'!
putNormal: aChar

	x >= cols ifTrue: [self wrapIfPossible].
	selectionActive ifTrue: [self protectSelection].
	self currentLine at: x put: (Character value: aChar) fg: fg bg: bg em: em! !

!TeletypeMorph methodsFor: 'character writing'!
resetVideo

	self
		clearSelection;
		setBackground: 7;
		setForeground: 0;
		setEmphasis: 0! !

!TeletypeMorph methodsFor: 'character writing'!
setBackground: index

	bg _ index min: 7 max: 0.! !

!TeletypeMorph methodsFor: 'character writing'!
setEmphasis: index

	index == 0 ifTrue: [^em _ 0].
	em _ em bitOr: (1 bitShift: index - 1).! !

!TeletypeMorph methodsFor: 'character writing'!
setEmphasis: index to: bit

	bit == 0
		ifTrue: [em _ em bitClear: (1 bitShift: index - 1)]
		ifFalse: [em _ em bitOr: (1 bitShift: index - 1)]! !

!TeletypeMorph methodsFor: 'character writing'!
setForeground: index

	fg _ index min: 7 max: 0! !

!TeletypeMorph methodsFor: 'cursor control'!
activePosition

	^x@y! !

!TeletypeMorph methodsFor: 'cursor control'!
activePosition: aPoint

	self hideCursor.
	x _ aPoint x min: cols max: 1.
	y _ aPoint y min: rows max: 1.
	relativeOrigin ifTrue: [y _ y + topLine - 1 min: bottomLine max: topLine].
	self showCursor! !

!TeletypeMorph methodsFor: 'cursor control'!
bs

	self cursorLeft: 1 wrapping: false! !

!TeletypeMorph methodsFor: 'cursor control'!
clearCursor

	lines do: [ :line | line cursorCol: 0]! !

!TeletypeMorph methodsFor: 'cursor control'!
cr

	self hideCursor.
	x _ 1.
	self showCursor! !

!TeletypeMorph methodsFor: 'cursor control'!
cursorDown: n scrolling: scrollFlag

	self hideCursor.
	n timesRepeat: [self cursorDownScrolling: scrollFlag].
	self showCursor! !

!TeletypeMorph methodsFor: 'cursor control'!
cursorLeft: n wrapping: wrapFlag

	self hideCursor.
	n timesRepeat: [self cursorLeftWrapping: wrapFlag].
	self showCursor! !

!TeletypeMorph methodsFor: 'cursor control'!
cursorRight: n wrapping: wrapFlag

	self hideCursor.
	n timesRepeat: [self cursorRightWrapping: wrapFlag].
	self showCursor! !

!TeletypeMorph methodsFor: 'cursor control'!
cursorUp: n scrolling: scrollFlag

	self hideCursor.
	n timesRepeat: [self cursorUpScrolling: scrollFlag].
	self showCursor! !

!TeletypeMorph methodsFor: 'cursor control'!
hideCursor

	self currentLine cursorCol: 0! !

!TeletypeMorph methodsFor: 'cursor control'!
lf

	autoCR
		ifTrue: [self newline]
		ifFalse: [self cursorDown: 1 scrolling: true]! !

!TeletypeMorph methodsFor: 'cursor control'!
newline

	self hideCursor; cursorDown: 1 scrolling: true.
	x _ 1.
	self showCursor! !

!TeletypeMorph methodsFor: 'cursor control'!
showCursor

	self currentLine cursorCol: x! !

!TeletypeMorph methodsFor: 'operating modes'!
doFullReset
	"Clear the screen, reset tabs to every eight columns, and reset the terminal modes (such as wrap and smooth scroll) to their initial states just after terminal initialisation."

	self
		doSoftReset;
		clearSelection;
		clearScreen;
		activePosition: 1@1;
		initializeTabs;
		initializeTerminalModes;
		changed! !

!TeletypeMorph methodsFor: 'operating modes'!
doResetAndClear
	"Reset the terminal to a sane state and clear the saved lines."

	self doFullReset.
	displayStart _ 0.
	savedLines _ 0.
	lines _ lines copyFrom: lines size - rows + 1 to: lines size.
	self linesChanged; changed! !

!TeletypeMorph methodsFor: 'operating modes'!
doSoftReset
	"Reset scroll regions.  This can be convenient when some program has left the scroll regions set incorrectly (often a problem when using VMS or TOPS-20)."

	topLine _ 1.
	bottomLine _ rows.! !

!TeletypeMorph methodsFor: 'operating modes'!
metaSendsEscape: aBoolean

	metaSendsEscape _ aBoolean! !

!TeletypeMorph methodsFor: 'operating modes'!
setAltScreenColours: aBoolean

	altScreenColours _ aBoolean.
	self setEmacsColours: ec.! !

!TeletypeMorph methodsFor: 'operating modes'!
setAutoLinefeed: aBoolean

	autoLinefeed _ aBoolean! !

!TeletypeMorph methodsFor: 'operating modes'!
setAutoWrap: aBoolean

	autoWrap _ aBoolean! !

!TeletypeMorph methodsFor: 'operating modes'!
setEmacsColours: aBoolean

	(ec _ aBoolean) & altScreenColours
		ifTrue: [submorphs from: 1 to: rows do: [:line | line emacsColours]]
		ifFalse: [submorphs from: 1 to: rows do: [:line | line normalColours]].
	self changed! !

!TeletypeMorph methodsFor: 'operating modes'!
setIconTitle: aString

	systemWindow notNil
		ifTrue:
			[(systemWindow isKindOf: TeletypeWindow)
				ifTrue: [systemWindow setIconTitle: aString]]
				"icon title ignored by other kinds of window"! !

!TeletypeMorph methodsFor: 'operating modes'!
setInsertMode: aBoolean

	insertMode _ aBoolean! !

!TeletypeMorph methodsFor: 'operating modes'!
setRelativeOrigin: aBoolean

	relativeOrigin _ aBoolean.
	self activePosition: 1@1! !

!TeletypeMorph methodsFor: 'operating modes'!
setReverseVideo: aBoolean

	reverseVideo == aBoolean ifTrue: [^self].
	reverseVideo _ aBoolean.
	submorphs from: 1 to: rows do: [ :m | m rv: (rv xor: reverseVideo)].
	self changed! !

!TeletypeMorph methodsFor: 'operating modes'!
setScrollRegionTop: top bottom: bottom

	topLine _ top min: rows - 1 max: 1.
	bottomLine _ bottom min: rows max: top + 1! !

!TeletypeMorph methodsFor: 'operating modes'!
setShowCursor: aBoolean

	self hideCursor.
	showCursor _ aBoolean.
	self showCursor! !

!TeletypeMorph methodsFor: 'operating modes'!
setSmoothScroll: aBoolean

	autoFlush _ 0.
	smoothScroll _ aBoolean! !

!TeletypeMorph methodsFor: 'operating modes'!
setWidth: nCols

	allow132 ifTrue: [self setWidth: nCols height: rows]! !

!TeletypeMorph methodsFor: 'operating modes'!
setWindowTitle: aString

	systemWindow notNil
		ifTrue:
			[(systemWindow isKindOf: TeletypeWindow)
				ifTrue: [systemWindow setWindowTitle: aString]
				ifFalse: [systemWindow setLabel: aString]]! !

!TeletypeMorph methodsFor: 'editor functions'!
clearLine

	self
		hideCursor;
		clearLine: y from: 1 to: cols;
		showCursor! !

!TeletypeMorph methodsFor: 'editor functions'!
clearLine: n from: l to: r

	(self lineAt: n)
		from: l to: r put: $  fg: fg bg: bg em: 0;
		lastColumn: l - 1.! !

!TeletypeMorph methodsFor: 'editor functions'!
clearLineLeft

	self
		clearSelection;
		hideCursor;
		clearLine: y from: 1 to: x;
		showCursor! !

!TeletypeMorph methodsFor: 'editor functions'!
clearLineRight

	self
		clearSelection;
		hideCursor;
		clearLine: y from: x to: cols;
		showCursor! !

!TeletypeMorph methodsFor: 'editor functions'!
clearScreen

	self hideCursor.
	1 to: rows do: [:i | self clearLine: i from: 1 to: cols].
	self showCursor.! !

!TeletypeMorph methodsFor: 'editor functions'!
clearScreenLeft

	self
		clearSelection;
		hideCursor;
		clearLine: y from: 1 to: x.
	1 to: y - 1 do: [:i | self clearLine: i from: 1 to: cols].
	self showCursor.
	self flush! !

!TeletypeMorph methodsFor: 'editor functions'!
clearScreenRight

	self
		clearSelection;
		hideCursor;
		clearLine: y from: x to: cols.
	y + 1 to: rows do: [:i | self clearLine: i from: 1 to: cols].
	self showCursor.
	self flush! !

!TeletypeMorph methodsFor: 'editor functions'!
deleteForward: n

	self hideCursor.
	n timesRepeat: [self deleteForward].
	self showCursor! !

!TeletypeMorph methodsFor: 'editor functions'!
deleteLines: n

	self hideCursor.
	n timesRepeat: [self deleteLine].
	self showCursor.
	self autoFlush! !

!TeletypeMorph methodsFor: 'editor functions'!
insert: n

	self hideCursor.
	n timesRepeat: [self insert].
	self showCursor! !

!TeletypeMorph methodsFor: 'editor functions'!
insertLines: n

	self hideCursor.
	n timesRepeat: [self insertLine].
	self showCursor.
	self autoFlush! !

!TeletypeMorph methodsFor: 'tabs'!
clearTab

	x <= cols ifTrue: [tabs at: x put: false].
"
	Transcript
		nextPutAll: 'tab CLR ', x printString; tab;
		nextPutAll: (String withAll: (tabs collect: [:t | t ifTrue: [$!!] ifFalse: [$.]]));
		cr; endEntry
"! !

!TeletypeMorph methodsFor: 'tabs'!
clearTabs

	tabs atAllPut: false.! !

!TeletypeMorph methodsFor: 'tabs'!
setTab

	x <= cols ifTrue: [tabs at: x put: true].
"
	Transcript
		nextPutAll: 'tab SET ', x printString; tab;
		nextPutAll: (String withAll: (tabs collect: [:t | t ifTrue: [$!!] ifFalse: [$.]]));
		cr; endEntry
"! !

!TeletypeMorph methodsFor: 'tabs'!
tab

	self hideCursor.
	[x _ x + 1.
	 x < cols and: [(tabs at: x) not]]
		whileTrue.
	x _ x min: cols.
	self showCursor.! !

!TeletypeMorph methodsFor: 'protocol'!
down: protoLo

	down _ protoLo! !

!TeletypeMorph methodsFor: 'protocol'!
flush

	submorphs from: 1 to: rows do: [ :m | m flush].
	autoFlush _ self autoFlushCount.
	self updateScrollbar.! !

!TeletypeMorph methodsFor: 'protocol'!
install

	session isNil ifFalse: [session propertyAt: #window put: self]! !

!TeletypeMorph methodsFor: 'protocol'!
isConnected

	^session notNil and: [session isConnected]! !

!TeletypeMorph methodsFor: 'protocol'!
note: aSymbol with: anObject

	aSymbol == #endpointClosed
		ifTrue:
			[^(systemWindow isKindOf: TeletypeWindow)
				ifTrue: [systemWindow endpointClosed]].

	aSymbol == #savePreferences ifTrue: [^self savePreferences: anObject].
	aSymbol == #loadPreferences ifTrue: [^self loadPreferences: anObject].
	aSymbol == #restoreDefaults ifTrue: 	[^self restoreDefaults]! !

!TeletypeMorph methodsFor: 'protocol'!
run

	running _ true.
	session isNil ifFalse: [session note: #windowSize with: cols@rows]! !

!TeletypeMorph methodsFor: 'protocol'!
session

	^session! !

!TeletypeMorph methodsFor: 'protocol'!
sessionNote: aSymbol

	self sessionNote: aSymbol with: nil! !

!TeletypeMorph methodsFor: 'protocol'!
sessionNote: aSymbol with: anObject

	session isNil ifFalse: [session note: aSymbol with: anObject]! !

!TeletypeMorph methodsFor: 'protocol'!
upcall: char
"
	Transcript show: 'upcall ', char printString; cr.
""	char printString , '   ' displayAt: 10@10.
"
	self put: char! !

!TeletypeMorph methodsFor: 'protocol'!
upcallAll: aCollection

	aCollection do: [:b | self upcall: b]! !

!TeletypeMorph methodsFor: 'menus'!
buildMainMenu

	| m |
	(m _ MenuMorph new) defaultTarget: self.
	m	add: 'redraw window' target: owner action: #changed;
			balloonTextForLastItem: 'Redisplay the contents of the window.';
		addLine.
	self
		menu: m add: 'meta sends escape' var: metaSendsEscape eval: [metaSendsEscape _ metaSendsEscape not]
			help: 'Send ESC before each keyboard character if the command key is pressed.';
		menu: m add: 'delete is del' var: deleteIsDel eval: [deleteIsDel _ deleteIsDel not]
			help: 'Send DEL instead of backspace.'.
	m addLine.
	m
		add: 'character classes ...' action: #menuSetCharacterClasses;
			balloonTextForLastItem: 'Modify the character classes used for double-click selection.'.
	self
		menu: m add: 'mouse controls clipboard' var: mouseControlsSelection eval: [mouseControlsSelection _ mouseControlsSelection not]
			help: 'If enabled then use xterm-style selection: selecting implies copy and the yellow button pastes.';
		menu: m add: 'keyboard controls clipboard' var: keyboardControlsSelection eval: [keyboardControlsSelection _ keyboardControlsSelection not]
			help: 'If enabled then use Squeak-style selection: cmd-c copies selection to clipboard and cmd-v pastes.'.
	m addLine.
	m
		add: 'saved line limit (', savedLineLimit printString, ') ...' action: #menuSetSavedLineLimit;
			balloonTextForLastItem: 'Set the maximum number of lines to save beyond the top of the window.'.
	m
		add: 'screen size (', cols printString, 'x', rows printString, ') ...' action: #menuResizeScreen;
			balloonTextForLastItem: 'Resize the screen to a given number of columns and rows.'.
	^m! !

!TeletypeMorph methodsFor: 'menus'!
buildVTMenu

	| m |
	(m _ MenuMorph new) defaultTarget: self.

	self
		menu: m add: 'enable scrollbar' var: useScrollbar eval: [self menuToggleScrollbar]
			help: 'Show the scrollbar.';
		menu: m add: 'enable jump scroll' var: smoothScroll not eval: [smoothScroll _ smoothScroll not]
			help: 'Allow several lines to be displayed at once when input is arriving quickly.';
		menu: m add: 'enable reverse video' var: reverseVideo eval: [self setReverseVideo: reverseVideo not; flush]
			help: 'Display the entire window in reverse video.';
		menu: m add: 'enable auto wraparound' var: autoWrap eval: [autoWrap _ autoWrap not]
			help: 'Automatically wrap to the next line when the cursor reaches the last column.';
		menu: m add: 'enable reverse wraparound' var: reverseWrap eval: [reverseWrap _ reverseWrap not]
			help: 'Automaticaly wrap to the previous line when the cursor moves left of the first column.';
		menu: m add: 'enable auto linefeed' var: autoLinefeed eval: [autoLinefeed _ autoLinefeed not]
			help: 'Move to the next line automatically when carriage return is received.';

		menu: m add: 'scroll to bottom on key press' var: scrollOnInput eval: [scrollOnInput _ scrollOnInput not]
			help: 'Automatically reposition the screen to the bottom of the scrolling region when keyboard input is received.';
		menu: m add: 'scroll to bottom on tty output' var: scrollOnOutput eval: [scrollOnOutput _ scrollOnOutput not]
			help: 'Automatically reposition the screen to the bottom of the scrolling region when application output is received.';

		menu: m add: 'allow 80/132 column switching' var: allow132 eval: [allow132 _ allow132 not]
			help: 'Allow the program to resize the window automatically using 80/132 column escape sequences.';

		menu: m add: 'enable alternate screen switching' var: altScreenSwitch eval: [altScreenSwitch _ altScreenSwitch not]
			help: 'Allow switching to the alternate screen buffer.';
		menu: m add: 'enable alternate screen colours' var: altScreenColours eval: [self setAltScreenColours: altScreenColours not]
			help: self emacsColoursHelpString.
	m addLine;
		add: 'do soft reset' action: #doSoftReset;
			balloonTextForLastItem: 'Reset the scroll regions.  This can be convenient when some program has left the scroll regions set incorrectly (often a problem when using VMS or TOPS-20).';
		add: 'do full reset' action: #doFullReset;
			balloonTextForLastItem: 'Clear the screen, reset tabs to every eight columns, and reset the terminal modes (such as wrap and smooth scroll) to their initial states just after terminal initialisation.';
		add: 'reset and clear saved lines' action: #doResetAndClear;
			balloonTextForLastItem: 'Perform a full reset and then forget all lines scrolled off the top of the window.'.

	^m! !

!TeletypeMorph methodsFor: 'menus'!
menu: aMenu add: aString var: aBoolean eval: aBlock help: helpString

	aMenu
		add: (aBoolean ifTrue: ['<yes>'] ifFalse: ['<no>']), aString
		selector: #menuBlock:
		argument: aBlock;
		balloonTextForLastItem: helpString! !

!TeletypeMorph methodsFor: 'menus'!
menuBlock: aBlock

	aBlock value.
	self flush! !

!TeletypeMorph methodsFor: 'menus'!
menuResizeScreen

	| n c r |
	n _ FillInTheBlank
		request: 'New screen size (columns x rows)?'
		initialAnswer: cols printString, 'x', rows printString.
	(n isNil or: [n isEmpty]) ifTrue: [^self].
	n _ n findTokens: 'x'.
	n size == 2 ifFalse: [^Smalltalk beep].
	(c _ n first asInteger) isNil ifTrue: [^Smalltalk beep].
	(r _ n last asInteger) isNil ifTrue: [^Smalltalk beep].
	self setWidth: c height: r! !

!TeletypeMorph methodsFor: 'menus'!
menuSetCharacterClasses

	| n specs spec cclass range start stop |
	n _ FillInTheBlank request: 'Character classes?  (Enter ? for help.)' initialAnswer: '?'.
	(n isNil or: [n isEmpty]) ifTrue: [^self].
	n = '?' ifTrue: [^self menuSetCharacterClassesHelp].
	specs _ n findTokens: ','.
	specs do: [ :aSpec |
		Transcript cr; show: aSpec.
		start _ stop _ cclass _ nil.
		spec _ aSpec findTokens: ':'.
		Transcript cr; show: spec printString.
		spec size == 2
			ifTrue:
				[cclass _ spec last asInteger.
				 range _ spec first findTokens: '-'.
				 Transcript cr; show: range printString.
				 (cclass notNil and: [range size >= 1 and: [range size <= 2]])
					ifTrue:
						[start _ range first asInteger.
						 stop _ (range size == 2 ifTrue: [range last] ifFalse: [range first]) asInteger]].
		stop isNil ifTrue: [^Smalltalk beep; inform: 'Could not parse: ', spec printString].
		cclass _ Character value: cclass.
		characterClasses from: start + 1 to: stop + 1 put: cclass.].

	(self confirm: 'Would you like the current character classes  to be the default?')
		ifTrue: [CharClass _ characterClasses]
! !

!TeletypeMorph methodsFor: 'menus'!
menuSetCharacterClassesHelp

	StringHolder new
		contents: 'This preference is a series of comma-separated range:value pairs.  The range is either a single number or low-high in the range of 0 to 255, corresponding to the code for the character or characters to be set.  The value is the class in which to place the characters in the range.  The value is arbitrary, but the standard character classes use the following values: 1 for special graphics characters, 32 for whitespace, 48 for alphanumeric characters (letters and digits), and the code of the character itself for all others (corresponding to puncuation characters).

For example,

		33:48,37:48,45-47:48,64:48

indicates that the exclamation mark, percent sign, dash, period, slash, and ampersand characters should be treated the same way as letters and digits.  This is useful for copying and pasting electronic mailing addresses and filenames.  Also,

		33:48,37:48,45-47:48,58:48,64:48,126:48

is similar but includes colon and tilde, making most URLs selectable with a double click.';
		openLabel: 'Character Class Help'! !

!TeletypeMorph methodsFor: 'menus'!
menuSetSavedLineLimit

	| n |
	n _ FillInTheBlank
		request: 'Saved line count?'
		initialAnswer: savedLineLimit printString.
	(n _ n asInteger) isNil ifTrue: [^self].
	savedLineLimit _ n.
	(self confirm: 'Would you like to make ', n printString, ' lines the default?')
		ifTrue: [SavedLineLimit _ n]! !

!TeletypeMorph methodsFor: 'menus'!
menuToggleScrollbar

	| scrollWidth |
	self hideScrollbar.
	useScrollbar _ useScrollbar not.
	scrollWidth _ scrollFlop
		ifTrue: [0]
		ifFalse: [useScrollbar ifTrue: [self scrollbarWidth] ifFalse: [self scrollbarWidth negated]].
	self initializeScrollbar.
	systemWindow isNil
		ifTrue: [self extent: self extent + (scrollWidth @ 0)]
		ifFalse: [systemWindow extent: systemWindow extent + (scrollWidth @ 0)]! !

!TeletypeMorph methodsFor: 'menus'!
offerVTMenu
	"The user has pressed CTRL-Yellow (button 2).  Offer a menu similar to the Xterm `VT' menu."

	(self buildVTMenu addStayUpIcons title: 'VT Options')
		popUpEvent: self currentEvent in: self world! !

!TeletypeMorph methodsFor: 'scrolling'!
hideOrShowScrollBar

	"ScrollBar sends us this for no good reason."! !

!TeletypeMorph methodsFor: 'scrolling'!
pageDown: nLines

	displayStart _ displayStart + nLines min: lines size - rows.
	self linesChanged; changed.! !

!TeletypeMorph methodsFor: 'scrolling'!
pageEnd

	 lines size - rows == displayStart
		ifFalse:
		[displayStart _ lines size - rows.
		 self linesChanged; changed]! !

!TeletypeMorph methodsFor: 'scrolling'!
pageHome

	displayStart _ 0.
	self linesChanged; changed.! !

!TeletypeMorph methodsFor: 'scrolling'!
pageUp: nLines

	displayStart _ displayStart - nLines max: 0.
	self linesChanged; changed.! !

!TeletypeMorph methodsFor: 'scrolling'!
scrollbarMenuButtonPressed: evt

	(systemWindow isKindOf: TeletypeWindow)
		ifTrue: [systemWindow offerWindowMenu]
		ifFalse: [self offerVTMenu]! !

!TeletypeMorph methodsFor: 'scrolling'!
scrollbarValue: value

	| newStart |
	newStart _ (savedLines * value) rounded min: lines size - rows.
	newStart == displayStart ifTrue: [^self].
	displayStart _ newStart.
	self linesChanged; changed! !

!TeletypeMorph methodsFor: 'scrolling'!
updateScrollbar

	scroll isNil ifTrue: [^self].
	savedLines == 0 ifTrue: [^scroll interval: 1.0; setValue: 0].
	scroll
		scrollDelta: (1 / savedLines) asFloat
		pageDelta: (rows / savedLines) asFloat;
		interval: (rows / lines size) asFloat;
		setValue: (displayStart / savedLines) asFloat! !

!TeletypeMorph methodsFor: 'private'!
autoFlush

	(autoFlush _ autoFlush - 1) < 1
		ifTrue:
			[self updateScrollbar; changed.
			 autoFlush _ self autoFlushCount.
			 Processor yield.]! !

!TeletypeMorph methodsFor: 'private'!
autoFlushCount

	^smoothScroll ifTrue: [2] ifFalse: [rows]! !

!TeletypeMorph methodsFor: 'private'!
banner

	^''! !

!TeletypeMorph methodsFor: 'private'!
currentLine

	^lines at: lines size - rows + y! !

!TeletypeMorph methodsFor: 'private'!
cursorDownScrolling: scrollFlag

	(y >= bottomLine and: [scrollFlag]) ifTrue: [self scrollForward].
	y _ y + 1 min: bottomLine! !

!TeletypeMorph methodsFor: 'private'!
cursorLeftWrapping: wrapFlag

	x > 1 ifTrue: [^x _ x - 1].
	(y > 1 and: [wrapFlag and: [reverseWrap]]) ifTrue: [x _ cols.  y _ y - 1]! !

!TeletypeMorph methodsFor: 'private'!
cursorRightWrapping: wrapFlag

	((x _ x + 1) > cols and: [wrapFlag not]) ifTrue: [x _ cols].! !

!TeletypeMorph methodsFor: 'private'!
cursorUpScrolling: scrollFlag

	(y <= topLine and: [scrollFlag]) ifTrue: [self scrollBackward].
	y _ y - 1 max: topLine! !

!TeletypeMorph methodsFor: 'private'!
debug: message

	Transcript nextPutAll: message; cr; endEntry! !

!TeletypeMorph methodsFor: 'private'!
debug: message with: arg

	Transcript nextPutAll: message; space; print: arg; cr; endEntry! !

!TeletypeMorph methodsFor: 'private'!
deleteForward

	(self protectSelection; currentLine) deleteCharAt: x! !

!TeletypeMorph methodsFor: 'private'!
deleteLine

	^self scrollForwardFrom: y to: bottomLine! !

!TeletypeMorph methodsFor: 'private'!
displayLineAt: index
	"Answer the displayed (visible) line at index."

	^lines at: displayStart + index! !

!TeletypeMorph methodsFor: 'private'!
displayLineAt: index put: anObject
	"Change the displayed (visible) line at index."

	^lines at: displayStart + index put: anObject! !

!TeletypeMorph methodsFor: 'private'!
displayLinesDo: aBlock

	lines from: displayStart + 1 to: displayStart + rows do: aBlock! !

!TeletypeMorph methodsFor: 'private'!
drawOn: aCanvas

	super drawOn: aCanvas.
	self updateScrollbar.! !

!TeletypeMorph methodsFor: 'private'!
emacsColoursHelpString
	"This is so long that it distracts from the menu building in progress."

	^'Use Emacs-style colours in the alternate screen buffer.

(Xterm has two independent screen buffers.  Programs such as "Emacs" and "less" run in the alternate buffer and switch back to the primary buffer when they exit -- hence preserving the original contents of the screen.  If this option is enabled then the alternate buffer will use a different colour scheme [similar to the one used by Emacs under X11] much better adapted to recent Emacsen [version 21 and higher] that are capable of using font-lock mode and colour highlighting when running in a terminal window.)'! !

!TeletypeMorph methodsFor: 'private'!
insert

	(self protectSelection; currentLine)
		at: x insert: $  fg: fg bg: bg em: em! !

!TeletypeMorph methodsFor: 'private'!
insertLine

	^self scrollBackwardFrom: y to: bottomLine! !

!TeletypeMorph methodsFor: 'private'!
lineAt: index

	^lines at: savedLines + index! !

!TeletypeMorph methodsFor: 'private'!
linesChanged

	| lineNo line |
	lineNo _ displayStart.
	1 to: rows do: [ :i |
		line _ lines at: (lineNo _ lineNo + 1).
		line setWidth: cols.
		(submorphs at: i) lineState: line].
	1 to: rows do: [ :i | (submorphs at: i) rv: rv; cursorColour: cursorColour; ec: ec & altScreenColours].
	self autoFlush! !

!TeletypeMorph methodsFor: 'private'!
linesDo: aBlock

	self linesFrom: 1 to: rows do: aBlock! !

!TeletypeMorph methodsFor: 'private'!
linesFrom: start to: stop do: aBlock

	| first |
	first _ lines size - rows.
	lines from: first + start to: first + stop do: aBlock! !

!TeletypeMorph methodsFor: 'private'!
loadPreferences: dict

	| r c s |
	(dict at: #saveTerminalMainOptions)
		ifTrue:
			[metaSendsEscape _ dict at: #metaSendsEscape.
			 deleteIsDel _ dict at: #deleteIsDel.
			 savedLineLimit _ dict at: #savedLineLimit.
			 characterClasses _ (dict at: #characterClasses) copy.
			 mouseControlsSelection _ dict at: #mouseControlsSelection.
			 keyboardControlsSelection _ dict at: #keyboardControlsSelection.
			 savedLineLimit _ dict at: #savedLineLimit].
	(dict at: #saveTerminalVTOptions)
		ifTrue:
			[s  _ dict at: #useScrollbar.
			 s == useScrollbar ifFalse: [self menuToggleScrollbar].
			 smoothScroll _ dict at: #smoothScroll.
			 reverseVideo _ dict at: #reverseVideo.
			 autoWrap _ dict at: #autoWrap.
			 reverseWrap _ dict at: #reverseWrap.
			 autoLinefeed _ dict at: #autoLinefeed.
			 autoCR _ dict at: #autoCR.
			 scrollOnInput _ dict at: #scrollOnInput.
			 scrollOnOutput _ dict at: #scrollOnOutput.
			 allow132 _ dict at: #allow132.
			 altScreenSwitch _ dict at: #altScreenSwitch.
			 altScreenColours _ dict at: #altScreenColours].
	(dict at: #saveTerminalSize)
		ifTrue:
			[r _ dict at: #rows.
			 c _ dict at: #cols.
			 (r == rows and: [c == cols]) ifFalse: [self setWidth: c height: r]]! !

!TeletypeMorph methodsFor: 'private'!
newLine

	| line |
	line _ (SimpleTextState string: (String new: cols withAll: $ )) .
	ec & altScreenColours ifTrue: [line emacsColours].
	^line! !

!TeletypeMorph methodsFor: 'private'!
protectSelection
	"If the active position is within the selected region, clear the selection."

	self flag: #ikp. "This is called way too often.  Need to go look where and when it's really necessary."
"
	'protect selection ', (TEMP _ TEMP + 1) printString, '  ' displayAt: 10@170.
"
	selectionActive ifTrue: [(self currentLine selectionSpansColumn: x) ifTrue: [self clearSelection]]! !

!TeletypeMorph methodsFor: 'private'!
reportSizeToSession

	session isNil ifFalse: [session note: #windowSize with: cols@rows]! !

!TeletypeMorph methodsFor: 'private'!
restoreDefaults

	self initializeTerminalModes.
	savedLineLimit _ SavedLineLimit.
	altScreenColours ifTrue: [self setAltScreenColours: false].
	mouseControlsSelection _ true.
	keyboardControlsSelection _ false.
	scrollOnInput _ false.
	scrollOnOutput _ true.
	allow132 _ true.
	characterClasses _ CharClass copy.
	useScrollbar ifTrue: [self menuToggleScrollbar].
	(cols == 80 and: [rows == 24]) ifFalse: [self setWidth: 80 height: 24]! !

!TeletypeMorph methodsFor: 'private'!
savePreferences: dict

	dict
		at: #rows put: rows;
		at: #cols put: cols;
		at: #savedLineLimit put: savedLineLimit;
		at: #useScrollbar put: useScrollbar;
		at: #autoWrap put: autoWrap;
		at: #reverseWrap put: reverseWrap;
		at: #autoLinefeed put: autoLinefeed;
		at: #autoCR put: autoCR;
		at: #smoothScroll put: smoothScroll;
		at: #metaSendsEscape put: metaSendsEscape;
		at: #deleteIsDel put: deleteIsDel;
		at: #altScreenSwitch put: altScreenSwitch;
		at: #altScreenColours put: altScreenColours;
		at: #reverseVideo put: reverseVideo;
		at: #mouseControlsSelection put: mouseControlsSelection;
		at: #keyboardControlsSelection put: keyboardControlsSelection;
		at: #scrollOnInput put: scrollOnInput;
		at: #scrollOnOutput put: scrollOnOutput;
		at: #allow132 put: allow132;
		at: #characterClasses put: characterClasses copy! !

!TeletypeMorph methodsFor: 'private'!
scrollBackward

	^self scrollBackwardFrom: topLine to: bottomLine! !

!TeletypeMorph methodsFor: 'private'!
scrollBackwardFrom: top to: bot

	self hideCursor.
	savedLines + bot to: savedLines + top + 1 by: -1 do: [ :i | lines at: i put: (lines at: i - 1)].
	lines at: savedLines + top put: (SimpleTextState new: cols).
	self showCursor.
	self linesChanged! !

!TeletypeMorph methodsFor: 'private'!
scrollForward

	^self scrollForwardFrom: topLine to: bottomLine! !

!TeletypeMorph methodsFor: 'private'!
scrollForwardFrom: top to: bot

	self hideCursor.
	(top == 1 and: [bot == rows and: [altScreenActive not]])
		ifTrue:
			[lines addLast: (SimpleTextState new: cols).
			 lines size > (savedLineLimit + rows)
				ifTrue: [lines removeFirst selection notNil ifTrue: [self clearSelection]]
				ifFalse:
					[savedLines _ savedLines + 1.
					 displayStart _ displayStart + 1]]
		ifFalse:
			[savedLines + top to: savedLines + bot - 1 do: [ :i | lines at: i put: (lines at: i + 1)].
			 lines at: savedLines + bot put: (SimpleTextState new: cols)].
	self showCursor.
	self linesChanged; autoFlush! !

!TeletypeMorph methodsFor: 'private'!
step

	steps _ steps + 1! !

!TeletypeMorph methodsFor: 'private'!
sync
	"Wait until the world has revolved at least once before proceeding."

	| s |
	s _ steps + 1.
	[steps < s] whileTrue: [^Processor yield]! !

!TeletypeMorph methodsFor: 'private'!
wrapIfPossible

	x > cols ifTrue: [autoWrap
		ifTrue: [x _ 1.  self cursorDown: 1 scrolling: true]
		ifFalse: [x _ cols]]! !


!TeletypeMorph class methodsFor: 'class initialization'!
initialize
	"TeletypeMorph initialize"

	self initializeCursor.
	self initializeCharacterClasses.
	SavedLineLimit _ 64.
	"Set the default selection handling behaviour."
	MouseControlsSelection _ true.
	KeyboardControlsSelection _ false.
	"Notes:
	If MouseControlsSelection then selected text is copied to the clipboard when selection tracking finishes and the yellow button pastes from the clipboard into the terminal window.  Note that this moves the VT Options menu off the yellowButton and onto control-yellowButton (which is usually bound to the morph menu by things beyond our control; i.e., the VT menu becomes unavailable from within the TtyMorph itself.).
	If KeyboardControlsSelection then cmd-c copies the last mouse selection to the clipboard and cmd-v pastes the clipboard text into the terminal.  Note that this means M-C and M-V will no longer be available to programs such as Emacs.
	Note also that these can be in effect simultaneously to have both mouse and keyboard control of the selection.
	By default we turn mouse selection on and keyboard selection off.  This way the TtyMorph responds to the mouse like a real xterm and the M-C and M-V keys are passed unhindered to Emacs."! !

!TeletypeMorph class methodsFor: 'class initialization'!
initializeCharacterClasses
	"TeletypeMorph initializeCharacterClasses asByteArray inspect"
	"Clicking the red button twice in rapid succession will cause all adjacent characters of the same class (e.g., letters, white space, punctuation) under the pointer to be selected.  Since different people have different preferences for what should be selected (for example, whether filenames should be selected as a whole or as individual path components) the default mapping can be overridden through the use of the CharClass variable.  The default collects whitespace, alphanumeric and special graphics characters into three classes.  Each punctuation character is in a class of its own.
	NOTE: in order to see the contents of some of the strings in this method you might have to select their contents and then use the window menu to change their font to Fixed."

	"Start with each character in its own class."
	CharClass _ (0 to: 255) asByteArray asString.
	"Put the ASCII whitespace characters (nul tab space) into the same class as space."
	#(0 9 32)
		do: [:c | CharClass at: 1 + c put: $ ].
	"Put the ASCII alphanumeric characters into the same class as `0'."
	'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz'
		do: [:c | CharClass at: 1 + c asciiValue put: $0].
	"Put the ISO 8859 Latin-1 accented characters into the same class as `0'."
	'��������������������������������������������������������������'
		do: [:c | CharClass at: 1 + c asciiValue put: $0].
	"Put the ANSI special graphics characters into the same class as SOH (char 1)."
	'


��������������������������������'
		do: [:c | CharClass at: 1 + c asciiValue put: (Character value: 1)].
	"All other characters are punctuation and remain singletons."
	^CharClass


	"The table below is pulled directly out of xterm.  Evaluate the following to yield an Array whose first element is the complete set of xterm char classes and whose second element contains just the three non-singleton classes:
	| s |
	s _ IdentityDictionary new.
	#(32 1 1 1 1 1 1 1 1 32 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 32
	   33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 48 48 48 48 48 48 48
	   48 48 58 59 60 61 62 63 64 48 48 48 48 48 48 48 48 48 48 48 48 48 48
	   48 48 48 48 48 48 48 48 48 48 48 48 91 92 93 94 48 96 48 48 48 48 48
	   48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 123 124
	   125 126 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
	   1 1 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
	   176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 48 48
	   48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 215 48
	   48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48
	   48 48 48 48 48 48 48 247 48 48 48 48 48 48 48 48)
		withIndexDo: [:e :i | (s at: e ifAbsent: [s at: e put: IdentitySet new]) add: i - 1].
	s _ s associationsDo: [:a | a value: a value asSortedCollection asByteArray].
	^Array with: s with: (s select: [:v | v size > 1])
	"! !

!TeletypeMorph class methodsFor: 'class initialization'!
initializeCursor
	"TeletypeMorph initializeCursor"
	"TextCursor showWhile: [Sensor waitButton]"

	TextCursor _   CursorWithMask derivedFrom:
		(Cursor
			extent: 16@16
			fromArray: #(
		2r0000000000000000
		2r0000111011100000
		2r0000001110000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000001110000000
		2r0000111011100000
		2r0000000000000000
		2r0)
			offset: -7@-7).! !

!TeletypeMorph class methodsFor: 'class initialization'!
showCharacterClasses
	"TeletypeMorph showCharacterClasses"

	| s range start stop |
	s _ IdentityDictionary new.
	CharClass asByteArray withIndexDo: [:e :i | (s at: e ifAbsent: [s at: e put: IdentitySet new]) add: i - 1].
	s _ (s associationsDo: [ :a | a value: a value asSortedCollection asByteArray]) select: [:v | v size > 1].
	s _ String streamContents: [ :str |
		s keys asSortedCollection do: [ :key |
			range _ ReadStream on: (s at: key).
			[range atEnd] whileFalse:
				[str nextPut: $,.start _ range next.
				 stop _ start.
				 [range atEnd not and: [stop + 1 == range peek]] whileTrue: [stop _ range next].
				 str nextPutAll: start printString.
				 start == stop ifFalse: [str nextPut: $-; nextPutAll: stop printString].
				 str nextPut: $:; nextPutAll: key printString]]].
	s _ s copyFrom: 2 to: s size.
	FillInTheBlank
		request: 'Character classes'
		initialAnswer: s! !

!TeletypeMorph class methodsFor: 'instance creation'!
new

	| tty |
	tty _ super new initialize: 80@24.
	^tty! !

!TeletypeMorph class methodsFor: 'examples'!
example
	"TeletypeMorph example"

	| echo tty |
	"Pushing tty onto localEcho will convert ASCII control chars into tty cursor commands."
	(echo _ ProtocolAdaptor new) localEcho asProtocolStack push: (tty _ self new openInHand); install; run.
	echo downcallAll: TeletypeMorph organization classComment string asByteArray.
	tty activePosition: 1@24; flush.
	^tty! !

!TeletypeMorph class methodsFor: 'examples'!
example2
	"TeletypeMorph example2"

	| top tty |
	top _ ScrollPane new scroller: (tty _ TeletypeMorph new).
	ProtocolAdaptor new localEcho asProtocolStack push: tty; install; run.
	top openInHand! !


!TeletypeWindow methodsFor: 'initialize-release'!
initialize

	super initialize.
	self setLabel: (windowTitle _ iconTitle _ 'Teletype').
	self extent: 10@10.! !

!TeletypeWindow methodsFor: 'initialize-release'!
openOn: ttyMorph
	"Open a new SystemWindow containing just a ttyMorph."

	| ext |
	self setLabel: windowTitle.
	tty _ ttyMorph setWindow: self.
	self
		addMorph: tty frame: (0 @ 0 corner: 1 @ 1);
		model: tty.
	"Figure out what our extent should be based on how much extra space we use for decoration."
	ext _ tty preferredExtent						"the extent that the tty would like to receive"
		+ self extent - self ttyLayoutBounds extent.	"window decoration"
	self activeHand keyboardFocus: nil.			"make sure we get focus when we're opened"
	self extent: ext; openInWorldExtent: ext.
	tty install; run! !

!TeletypeWindow methodsFor: 'initialize-release'!
openOn: ttyMorph labeled: aString
	"Open a new SystemWindow containing just a ttyMorph."

	windowTitle _ iconTitle _ aString.
	^self openOn: ttyMorph! !

!TeletypeWindow methodsFor: 'accessing'!
setIconTitle: aString

	iconTitle _ aString.
	self isCollapsed ifTrue: [self setLabel: aString].! !

!TeletypeWindow methodsFor: 'accessing'!
setWindowTitle: aString

	windowTitle _ aString.
	self isCollapsed ifFalse: [self setLabel: aString].! !

!TeletypeWindow methodsFor: 'connections'!
closeConnection

	(self confirm: 'Really disconnect?') ifTrue: [tty session endpoint close]! !

!TeletypeWindow methodsFor: 'connections'!
endpointClosed

	AutoClose ifTrue: [^self delete].
	self setLabel: (windowTitle _ iconTitle _ 'disconnected').
	(ProtocolAdaptor new localEcho) asProtocolStack push: tty; install; run! !

!TeletypeWindow methodsFor: 'connections'!
newConnection

	| remote host port |
	remote _ FillInTheBlank
		request: 'Remote host name and port?'
		initialAnswer: 'localhost 23'.
	(remote isNil or: [remote size == 0]) ifTrue: [^nil].
	remote _ remote substrings.
	remote size < 1 ifTrue: [^nil].
	host _ remote first.
	port _ remote size > 1 ifTrue: [remote last asInteger].
	port isNil ifTrue: [port _ 23].
	self newConnection: host port: port! !

!TeletypeWindow methodsFor: 'connections'!
newConnection: args

	^self newConnection: args preferences: nil! !

!TeletypeWindow methodsFor: 'connections'!
newConnection: hostName port: portNumber

	| ep |
	tty upcallAll: ('Trying ', hostName, '...') asByteArray; newline; flush.
	ep _ NetworkEndpoint newConnection: hostName port: portNumber.
	ep isNil ifTrue: [^self error: 'Could not connect'].
	self setIconTitle: hostName; setWindowTitle: hostName.
	^ep asProtocolStack
		push:		TelnetProtocol new;
		push:		TerminalType new;
		push:		tty;
		install;
		run! !

!TeletypeWindow methodsFor: 'connections'!
newConnection: args preferences: prefs

	| hostName portNumber ep params |
	hostName _ args first.
	portNumber _ args last.
	params _ prefs isNil ifTrue: [IdentityDictionary new] ifFalse: [prefs].
	tty upcallAll: ('Trying ', hostName, '...') asByteArray; newline; flush.
	ep _ NetworkEndpoint newConnection: hostName port: portNumber.
	ep isNil ifTrue: [^self error: 'Could not connect'].
	self setIconTitle: hostName; setWindowTitle: hostName.
	^ep asProtocolStack
		push: TelnetProtocol new;
		push: TerminalType new;
		push: tty;
		note: #loadPreferences with: params;
		install;
		run! !

!TeletypeWindow methodsFor: 'connections'!
newShell

	| shell argv prog |
	shell _ FillInTheBlank
		request: 'Shell command?'
		initialAnswer: '/bin/bash -i'.
	argv _ shell substrings.
	argv isEmpty ifTrue: [^self].
	prog _ argv first.
	argv _ argv copyFrom: 2 to: argv size.
	self setIconTitle: prog; setWindowTitle: prog.
	(ProcessEndpoint command: prog arguments: argv) asProtocolStack
		push:		TerminalType new;
		push:		tty;
		install;
		run
! !

!TeletypeWindow methodsFor: 'connections'!
newShell: args

	^self newShell: args preferences: nil! !

!TeletypeWindow methodsFor: 'connections'!
newShell: args preferences: prefs

	| argv prog params |
	prog _ args first.
	argv _ args last.
	params _ prefs isNil ifTrue: [IdentityDictionary new] ifFalse: [prefs].
	self setIconTitle: prog; setWindowTitle: prog.
	(ProcessEndpoint command: prog arguments: argv) asProtocolStack
		push: TerminalType new;
		push: tty;
		note: #loadPreferences with: params;
		install;
		run
! !

!TeletypeWindow methodsFor: 'connections'!
newShortcut: shortcut

	| epClass epArgs |
	self savePreferences: shortcut.
	epClass _ shortcut at: #endpointClass.
	epArgs _ shortcut at: #endpointArguments.
	epClass == #ProcessEndpoint ifTrue: [^self newShell: epArgs preferences: shortcut].
	epClass == #NetworkEndpoint ifTrue: [^self newConnection: epArgs preferences: shortcut].
	self error: 'I don''t know how to create an endpoint of type ', epClass! !

!TeletypeWindow methodsFor: 'events'!
collapseOrExpand

	super collapseOrExpand.
	self setLabel: (self isCollapsed ifTrue: [iconTitle] ifFalse: [windowTitle])! !

!TeletypeWindow methodsFor: 'events'!
delete

	(tty isConnected not or: [self confirm: 'There is a session in progress.
Would you like to disconnect and close?
(Answering no will abandon the close request.)'])
		ifFalse: [^self].
	tty delete.
	^super delete
! !

!TeletypeWindow methodsFor: 'events'!
doFastWindowReframe: ptName
	"Override to provide geometry feedback at display top left and to ensure sane gridding of final bounds."

	| newBounds delta flak w pitch skip grid h |
	"For fast display, only higlight the rectangle during loop"
	flak _ self bounds extent - tty textBounds extent.
	pitch _ tty pitch.
	skip _ tty skip.
	grid _ pitch@skip.
	newBounds _ self bounds newRectButtonPressedDo: [:f | 
		delta _ f extent - flak grid: grid.
		w _ delta x // pitch.
		h _ delta y // skip.
		delta _ delta + flak.
		((' ', w printString, 'x', h printString, ' ') forceTo: 10 paddingWith: $ ) displayAt: 5@5.
		f 
			withSideOrCorner: ptName
			setToPoint: (self pointFromWorld: Sensor cursorPoint)
			minExtent: self minimumExtent].
	delta _ (newBounds extent - flak grid: grid) + flak.
	self bounds: (newBounds origin extent: delta).
	self world invalidRect: (5@5 extent: (TextMorph new contents: '999x999') extent)! !

!TeletypeWindow methodsFor: 'events'!
extent: aPoint

	super extent: aPoint.
	self isCollapsed ifTrue: [^self].
	tty notNil ifTrue: [tty extent: self ttyLayoutBounds extent].! !

!TeletypeWindow methodsFor: 'events'!
qdoFastWindowReframe: ptName
	"Override to provide geometry feedback at display top left and to ensure sane gridding of final bounds."

	| newBounds delta flak w pitch skip grid h |
	"For fast display, only higlight the rectangle during loop"
	flak _ self bounds extent - tty textBounds extent.
	pitch _ tty pitch.
	skip _ tty skip.
	grid _ pitch@skip.
	newBounds _ self bounds newRectButtonPressedDo: [:f | 
		delta _ f extent - flak grid: grid.
		w _ delta x // pitch.
		h _ delta y // skip.
		delta _ delta + flak.
		((' ', w printString, 'x', h printString, ' ') forceTo: 10 paddingWith: $ ) displayAt: 5@5.
		f 
			withSideOrCorner: ptName
			setToPoint: (self pointFromWorld: Sensor cursorPoint)
			minExtent: self minimumExtent].
	delta _ (newBounds extent - flak grid: grid) + flak.
	self bounds: (newBounds origin extent: delta).
	self world invalidRect: (5@5 extent: (TextMorph new contents: '999x999') extent).
	self activeHand newKeyboardFocus: self! !

!TeletypeWindow methodsFor: 'menus-window'!
addConnectMenuTo: aMenu

	| connectMenu removeMenu value |

	Shortcuts isEmpty
		ifFalse:
			[connectMenu _ MenuMorph new defaultTarget: self.
			 removeMenu _ MenuMorph new defaultTarget: self.
			 Shortcuts keys asSortedCollection do: [ :key |
				value _ Shortcuts at: key.
				connectMenu add: key selector: #newShortcut: argument: value.
				connectMenu balloonTextForLastItem: 'Open a session for ', (value at: #endpointArguments) first printString, '.'.
				removeMenu add: key selector: #removeShortcut: argument: key.
				removeMenu balloonTextForLastItem: 'Delete the shorcut for ', (value at: #endpointArguments) first printString, '.'].
			 connectMenu addLine.
			 connectMenu add: 'remove shortcut ' subMenu: removeMenu.
			 connectMenu balloonTextForLastItem: 'Delete a shortcut.'.
			 connectMenu add: 'clear shortcuts' selector: #menuBlock: argument: [Shortcuts _ Dictionary new].
			 connectMenu balloonTextForLastItem: 'Delete all shortcuts.'.
			 aMenu add: 'shortcuts ' subMenu: connectMenu.
			 aMenu balloonTextForLastItem: 'Open a session from a previously saved shortcut.'].

	aMenu add: 'new shell session ...' action: #newShell;
		balloonTextForLastItem: 'Run a new local program in this window.'.
	aMenu add: 'new telnet session ...' action: #newConnection;
		balloonTextForLastItem: 'Open a new telnet connection in this window.'.! !

!TeletypeWindow methodsFor: 'menus-window'!
buildWindowMenu

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	tty isConnected
		ifTrue:
			[aMenu add: 'disconnect' action: #closeConnection.
			 aMenu balloonTextForLastItem: 'Shut down the current session.'.
			 aMenu add: 'save shortcut ...' action: #menuSaveShortcut.
			 aMenu balloonTextForLastItem: 'Save (or modify) a shortcut for the current session.']
		ifFalse:
			[self addConnectMenuTo: aMenu].

	aMenu addLine
		add: 'new window' selector: #menuBlock: argument: [TeletypeWindow open];
		balloonTextForLastItem: 'Open a new, independent teletype window.'.

	tty isConnected
		ifTrue: [aMenu add: 'disconnect and close' action: #delete;
			 		balloonTextForLastItem: 'Shut down the current session and close the window.'.]
		ifFalse: [aMenu add: 'close window' action: #delete;
			 		balloonTextForLastItem: 'Close the window.'.].

	aMenu addLine;
		add: 'main options' subMenu: tty buildMainMenu;
		balloonTextForLastItem: 'Modify generalt terminal options.';
		add: 'vt options ' subMenu: tty buildVTMenu;
		balloonTextForLastItem: 'Modify VT100 emulation options.';
		add: 'telnet options ' subMenu: TelnetProtocol buildOptionsMenu;
		balloonTextForLastItem: 'Modify telnet protocol options.'.
	aMenu addLine;
		add: 'preferences ' subMenu: self buildConfigMenu;
		balloonTextForLastItem: 'Set preferences for shell and telnet sessions.'.
	aMenu addLine;
		add: 'window ' subMenu: super buildWindowMenu;
		balloonTextForLastItem: 'Modify the characteristics of this window.'.


	^aMenu! !

!TeletypeWindow methodsFor: 'menus-window'!
menuSaveShortcut

	| shortcut name | 
	shortcut _ IdentityDictionary new.
	shortcut at: #sessionType put: #unknown.
	tty sessionNote: #savePreferences with: shortcut.
	name _ FillInTheBlank request: 'Shortcut name?' initialAnswer: 'Untitled'.
	(name isNil or: [name isEmpty]) ifTrue: [^self].
	((Shortcuts includesKey: name) and: [(self confirm: 'Replace existing shortcut called `', name, '''?') not])
		ifTrue: [^self].
	Shortcuts at: name put: shortcut.! !

!TeletypeWindow methodsFor: 'menus-window'!
offerWindowMenu

	| aMenu |
	aMenu _ self buildWindowMenu.
	aMenu popUpEvent: self currentEvent in: self world! !

!TeletypeWindow methodsFor: 'menus-window'!
removeShortcut: name

	Shortcuts removeKey: name ifAbsent: []! !

!TeletypeWindow methodsFor: 'menus-config'!
buildConfigMenu

	| m |
	m _ MenuMorph new defaultTarget: self.

	m
		add: 'terminal type (', TerminalType terminalTypeName, ') '
		subMenu: ((MenuMorph new defaultTarget: self)
			add: 'vt102' selector: #menuBlock: argument: [TerminalType _ VT102Emulator];
			balloonTextForLastItem: 'Emulate a VT102 terminal.';
			add: 'xterm' selector: #menuBlock: argument: [TerminalType _ XtermEmulator];
			balloonTextForLastItem: 'Emulate an xterm terminal.');
		balloonTextForLastItem: 'Select the kind of terminal emulation to use.'.
	m
		add: 'font (', SimpleTextMorph defaultFont, ')' subMenu: self buildFontMenu;
		balloonTextForLastItem: 'Set the default font for terminal windows.
(Changes take effect in NEW windows, not this one.)'.

	self menu: m add: 'enable auto-close' var: AutoClose eval: [AutoClose _ AutoClose not]
			help: 'Automatically close the window when the session terminates.'.
	m addLine.

	self menu: m add: 'save screen size' var: SaveTerminalSize
			eval: [SaveTerminalSize _ SaveTerminalSize not]
			help: 'Save terminal screen size in shortcuts and restore it in new sessions.'.
	self menu: m add: 'save main options' var: SaveTerminalMainOptions
			eval: [SaveTerminalMainOptions _ SaveTerminalMainOptions not]
			help: 'Save terminal main options in shortcuts and restore them in new sessions.'.
	self menu: m add: 'save vt options' var: SaveTerminalVTOptions
			eval: [SaveTerminalVTOptions _ SaveTerminalVTOptions not]
			help: 'Save terminal VT options in shortcuts and restore them in new sessions.'.
	self menu: m add: 'save telnet options' var: SaveTelnetOptions
			eval: [SaveTelnetOptions _ SaveTelnetOptions not]
			help: 'Save telnet protocol options in shortcuts and restore them in new sessions.'.

	m addLine; add: 'restore defaults' selector: #menuBlock: argument: [self menuRestoreDefaults];
		balloonTextForLastItem: 'Reset ALL preferences and option values to their factory settings.'.

	^m! !

!TeletypeWindow methodsFor: 'menus-config'!
buildFontMenu
	| m |
	m _ MenuMorph new defaultTarget: SimpleTextMorph.
	StrikeFont monospacedFamilyNames do: [ :family |
		m add: family
		selector: #defaultFont:
		argument: family;
		 balloonTextForLastItem: 'Set the default font to ', family, '.
(Changes take effect in NEW windows, not this one.)'
	].
	^ m! !

!TeletypeWindow methodsFor: 'menus-config'!
menuRestoreDefaults

	(self confirm: 'Really restore all defaults?
 Note: this will also clear all of your shortcuts!! ') ifFalse: [^self].
	TeletypeWindow initialize.
	TeletypeMorph initialize.
	VT102Emulator initialize.
	XtermEmulator initialize.
	TelnetProtocol initialize.
	tty sessionNote: #restoreDefaults
	! !

!TeletypeWindow methodsFor: 'private'!
menu: aMenu add: aString var: aBoolean eval: aBlock help: helpString

	aMenu
		add: (aBoolean ifTrue: ['<yes>'] ifFalse: ['<no>']), aString
		selector: #menuBlock:
		argument: aBlock;
		balloonTextForLastItem: helpString! !

!TeletypeWindow methodsFor: 'private'!
menuBlock: aBlock

	aBlock value! !

!TeletypeWindow methodsFor: 'private'!
savePreferences: dict

	dict
		at: # saveTerminalSize put: SaveTerminalSize;
		at: # saveTerminalMainOptions put: SaveTerminalMainOptions;
		at: # saveTerminalVTOptions put: SaveTerminalVTOptions;
		at: # saveTelnetOptions put: SaveTelnetOptions! !

!TeletypeWindow methodsFor: 'private'!
setLabel: aString

	labelString = aString ifFalse: [super setLabel: aString]! !

!TeletypeWindow methodsFor: 'private'!
ttyLayoutBounds

	^self layoutBounds! !


!TeletypeWindow class methodsFor: 'class initialization'!
initialize
	"TeletypeWindow initialize"

	AutoClose _ false.
	SaveTelnetOptions _ false.
	SaveTerminalMainOptions _ true.
	SaveTerminalSize _ false.
	SaveTerminalVTOptions _ true.
	TerminalType _ XtermEmulator.
	Shortcuts _ Dictionary new.
	! !

!TeletypeWindow class methodsFor: 'instance creation'!
new

	^super new initialize! !

!TeletypeWindow class methodsFor: 'instance creation'!
open

	^self new openOn: TeletypeMorph new! !

!TeletypeWindow class methodsFor: 'instance creation'!
telnet: hostName
	"TeletypeWindow telnet: 'localhost'"

	^self telnet: hostName port: 23! !

!TeletypeWindow class methodsFor: 'instance creation'!
telnet: hostName port: portNumber
	"TeletypeWindow telnet: 'localhost' port: 23"

	| ep tty |
	ep _ NetworkEndpoint newConnection: hostName port: portNumber.
	ep isNil ifTrue: [^self error: 'Could not connect'].
	self new openOn: (tty _ TeletypeMorph new).
	ep asProtocolStack
		push:	TelnetProtocol new;
		push:	TerminalType new;
		push:	tty;
		install;
		run! !


!TelnetProtocol methodsFor: 'initialize-release'!
initialState: aState

	super initialState: aState.
	self
		setDebug: Debug;
		setDumpNetData: DumpNetData;
		setDumpTermData: DumpTermData.
	"negotiated state"
	doNAWS _ false.
	cols _ rows _ 0.! !

!TelnetProtocol methodsFor: 'initialize-release'!
setDebug: aBoolean

	debug _ aBoolean! !

!TelnetProtocol methodsFor: 'initialize-release'!
setDumpNetData: aBoolean

	dumpNetData _ aBoolean! !

!TelnetProtocol methodsFor: 'initialize-release'!
setDumpTermData: aBoolean

	dumpTermData _ aBoolean! !

!TelnetProtocol methodsFor: 'commands-do'!
iacDo: arg

	debug ifTrue: [self rcvd: Do with: arg].
	"Assume it's a command we don't want to deal with: refuse it."
	self sendIacWont: arg! !

!TelnetProtocol methodsFor: 'commands-do'!
iacDoEcho: arg

	debug ifTrue: [self rcvd: Do with: Echo].
	self sendIacWont: Echo! !

!TelnetProtocol methodsFor: 'commands-do'!
iacDoEnvironmentOpt: arg

	debug ifTrue: [self rcvd: Do with: arg].
	self sendIacWont: arg! !

!TelnetProtocol methodsFor: 'commands-do'!
iacDoFlowControl: arg

	debug ifTrue: [self rcvd: Do with: arg].! !

!TelnetProtocol methodsFor: 'commands-do'!
iacDoNAWS: arg

	debug ifTrue: [self rcvd: Do with: arg].
	doNAWS _ true.
	(cols ~~ 0 and: [rows ~~ 0])	"previous negotiation delayed"
		ifTrue: [self sbWindowSizeSendCols: cols rows: rows]! !

!TelnetProtocol methodsFor: 'commands-do'!
iacDoNewEnvironment: arg

	debug ifTrue: [self rcvd: Do with: arg].
	self sendIacWont: arg! !

!TelnetProtocol methodsFor: 'commands-do'!
iacDoTerminalSpeed: arg

	debug ifTrue: [self rcvd: Do with: arg].
	self sendIacWont: arg! !

!TelnetProtocol methodsFor: 'commands-do'!
iacDoTerminalType: arg

	debug ifTrue: [self rcvd: Do with: arg].! !

!TelnetProtocol methodsFor: 'commands-do'!
iacDoXDisplay: arg

	debug ifTrue: [self rcvd: Do with: arg].
	self sendIacWont: arg! !

!TelnetProtocol methodsFor: 'commands-dont'!
iacDont: arg

	debug ifTrue: [self rcvd: Dont with: arg]! !

!TelnetProtocol methodsFor: 'commands-dont'!
iacDontNAWS: arg

	debug ifTrue: [self rcvd: Dont with: arg].! !

!TelnetProtocol methodsFor: 'commands-will'!
iacWill: arg

	debug ifTrue: [self rcvd: Will with: arg].
	self sendIacDont: arg! !

!TelnetProtocol methodsFor: 'commands-will'!
iacWillEcho: arg

	debug ifTrue: [self rcvd: Will with: arg].
	self sendIacDo: arg! !

!TelnetProtocol methodsFor: 'commands-will'!
iacWillSuppressGoAhead: arg

	debug ifTrue: [self rcvd: Will with: arg]! !

!TelnetProtocol methodsFor: 'commands-subnegotiation'!
iacSB: arg

	debug ifTrue: [self rcvd: SB with: arg]! !

!TelnetProtocol methodsFor: 'commands-subnegotiation'!
iacSE: arg

	debug ifTrue: [self rcvd: SE with: arg]! !

!TelnetProtocol methodsFor: 'commands-other'!
iacDataMark: arg

	debug ifTrue: [self rcvd: DataMark]! !

!TelnetProtocol methodsFor: 'commands-other'!
iacIgnored: arg

	debug ifTrue: [self rcvd: arg].! !

!TelnetProtocol methodsFor: 'commands-outgoing'!
sbTerminalTypeSend: arg

	debug ifTrue: [self rcvd: SB with: TerminalType sub: Send].
	self
		sendIacSb: TerminalType
		isString: (session propertyAt: #terminalType ifAbsent: ['network'])! !

!TelnetProtocol methodsFor: 'commands-outgoing'!
sbWindowSizeSendCols: c rows: r

	doNAWS
		ifTrue: [self sendIacSb: NAWS isShort: c short: r.  cols _ rows _ 0.]
		ifFalse: [cols _ c.  rows _ r]		"delay for future negotiation"! !

!TelnetProtocol methodsFor: 'commands-outgoing'!
sendIac: arg

	down downcallAll: (ByteArray with: IAC with: arg).
	debug ifTrue: [self sent: arg]! !

!TelnetProtocol methodsFor: 'commands-outgoing'!
sendIacDo: arg

	down downcallAll: (ByteArray with: IAC with: Do with: arg).
	debug ifTrue: [self sent: Do with: arg]! !

!TelnetProtocol methodsFor: 'commands-outgoing'!
sendIacDont: arg

	down downcallAll: (ByteArray with: IAC with: Dont with: arg).
	debug ifTrue: [self sent: Dont with: arg]! !

!TelnetProtocol methodsFor: 'commands-outgoing'!
sendIacSb: arg isShort: s1 short: s2

	down downcallAll: (ByteArray streamContents: [:str | str
		nextPut: IAC;
		nextPut: SB;
		nextPut: arg;
		nextPut: Is;
		nextPut: (s1 bitAnd: 16rFF); nextPut: (s1 bitShift: -8);
		nextPut: (s2 bitAnd: 16rFF); nextPut: (s2 bitShift: -8);
		nextPut: IAC;
		nextPut: SE]).
	debug ifTrue: [self sent: SB with: arg sub: Is short: s1 short: s2]! !

!TelnetProtocol methodsFor: 'commands-outgoing'!
sendIacSb: arg isString: data

	down downcallAll: (ByteArray streamContents: [:str | str
		nextPut: IAC;
		nextPut: SB;
		nextPut: arg;
		nextPut: Is;
		nextPutAll: data asByteArray;
		nextPut: IAC;
		nextPut: SE]).
	debug ifTrue: [self sent: SB with: arg sub: Is string: data]! !

!TelnetProtocol methodsFor: 'commands-outgoing'!
sendIacWill: arg

	down downcallAll: (ByteArray with: IAC with: Will with: arg).
	debug ifTrue: [self sent: Will with: arg]! !

!TelnetProtocol methodsFor: 'commands-outgoing'!
sendIacWont: arg

	down downcallAll: (ByteArray with: IAC with: Wont with: arg).
	debug ifTrue: [self sent: Wont with: arg]! !

!TelnetProtocol methodsFor: 'protocol'!
downcall: aChar

	dumpTermData ifTrue: [self dump: '['; dumpHex: aChar; dump: ']'].
	super downcall: aChar! !

!TelnetProtocol methodsFor: 'protocol'!
note: aSymbol with: anObject

	super note: aSymbol with: anObject.
	aSymbol == #windowSize		ifTrue: [^self sbWindowSizeSendCols: anObject x rows: anObject y].
	aSymbol == #savePreferences	ifTrue: [^self savePreferences: anObject].
	aSymbol == #loadPreferences	ifTrue: [^self loadPreferences: anObject].
	aSymbol == #restoreDefaults	ifTrue: [^self restoreDefaults]! !

!TelnetProtocol methodsFor: 'protocol'!
run
	super run.
	super sessionNote: #oobInlineEndpoint.
	self
		sendIacDo: SuppressGoAhead;
		sendIacWill: TerminalType;
		sendIacWill: NAWS! !

!TelnetProtocol methodsFor: 'protocol'!
upcall: aChar

	dumpNetData ifTrue: [self dump: '<'; dumpHex: aChar; dump: '>'].
	super upcall: aChar! !

!TelnetProtocol methodsFor: 'debugging'!
commandName: cmd

	^Commands at: cmd ifAbsent: [cmd printString]! !

!TelnetProtocol methodsFor: 'debugging'!
cr

	self dump: String cr withInternetLineEndings! !

!TelnetProtocol methodsFor: 'debugging'!
debug: message

	self dump: message; dump: String crlf! !

!TelnetProtocol methodsFor: 'debugging'!
dump: message

	message do: [:c | up upcall: c asInteger].
	up flush! !

!TelnetProtocol methodsFor: 'debugging'!
dumpHex: char

	| str |
	str _ char printStringBase: 16.
	str _ str copyFrom: 4 to: str size.
	self dump: (str padded: #left to: 2 with: $0)! !

!TelnetProtocol methodsFor: 'debugging'!
initWindow

	('Connected to ', session endpoint name, '.
') withInternetLineEndings asByteArray do: [:c | self upcall: c]! !

!TelnetProtocol methodsFor: 'debugging'!
optionName: opt

	^Options at: opt ifAbsent: [opt printString]! !

!TelnetProtocol methodsFor: 'debugging'!
rcvd: cmd

	self debug: 'RCVD ', (self commandName: cmd)! !

!TelnetProtocol methodsFor: 'debugging'!
rcvd: cmd with: opt

	self debug: 'RCVD ', (self commandName: cmd), ' ', (self optionName: opt)! !

!TelnetProtocol methodsFor: 'debugging'!
rcvd: cmd with: opt sub: sub

	self debug:
		'RCVD ', (self commandName: cmd),
		' ', (self optionName: opt),
		' ', (self subnegotiationName: sub)! !

!TelnetProtocol methodsFor: 'debugging'!
sent: cmd

	self debug: 'SENT ', (self commandName: cmd)! !

!TelnetProtocol methodsFor: 'debugging'!
sent: cmd with: opt

	self debug: 'SENT ', (self commandName: cmd), ' ', (self optionName: opt)! !

!TelnetProtocol methodsFor: 'debugging'!
sent: cmd with: opt sub: sub short: s1 short: s2

	self debug: 'SENT ', (self commandName: cmd),
		' ', (self optionName: opt),
		' ', (self subnegotiationName: sub),
		' ', (s1 bitShift: -8) printString, ' ', (s1 bitAnd: 16rFF) printString, ' (', s1 printString, ')',
		' ', (s2 bitShift: -8) printString, ' ', (s2 bitAnd: 16rFF) printString, ' (', s2 printString, ')'! !

!TelnetProtocol methodsFor: 'debugging'!
sent: cmd with: opt sub: sub string: str

	self debug: 'SENT ', (self commandName: cmd),
		' ', (self optionName: opt),
		' ', (self subnegotiationName: sub),
		' "', str, '"'! !

!TelnetProtocol methodsFor: 'debugging'!
subnegotiationName: sub

	^Subnegotiation at: sub ifAbsent: [sub printString]! !

!TelnetProtocol methodsFor: 'private'!
loadPreferences: dict

	debug _ dict at: #telnetOptionsDebugging! !

!TelnetProtocol methodsFor: 'private'!
restoreDefaults

	debug _ Debug.
	dumpNetData _ DumpNetData.
	dumpTermData _ DumpTermData.! !

!TelnetProtocol methodsFor: 'private'!
savePreferences: dict

	dict at: #telnetOptionsDebugging put: debug! !


!TelnetProtocol class methodsFor: 'class initialization'!
initialize
	"TelnetProtocol initialize"

	Debug _ false.
	DumpNetData _ false.
	DumpTermData _ false.
	self initializeConstants.
	self initializeProtocol.! !

!TelnetProtocol class methodsFor: 'class initialization'!
initializeConstants

	(Commands _ IdentityDictionary new)
		"	constant name		  value		 diagnostic name	disobfuscational remarks"
		at: (SE					_ 240)	put: 'SE';				"Subnegotiation End"
		at: (Nop					_ 241)	put: 'NOP';				"No OPeration"
		at: (DataMark			_ 242)	put: 'DATA-MARK';
		at: (Break				_ 243)	put: 'BREAK';
		at: (IP					_ 244)	put: 'IP';				"Interrupt Process"
		at: (AO					_ 245)	put: 'AO';				"Abort Output"
		at: (AYT					_ 246)	put: 'AYT';				"Are You There?"
		at: (EC					_ 247)	put: 'EC';				"Erase Character"
		at: (EL					_ 248)	put: 'EL';				"Erase Line"
		at: (GoAhead			_ 249)	put: 'GO-AHEAD';
		at: (SB					_ 250)	put: 'SB';				"Subnegotiation Begin"
		at: (Will					_ 251)	put: 'WILL';
		at: (Wont				_ 252)	put: 'WONT';
		at: (Do					_ 253)	put: 'DO';
		at: (Dont				_ 254)	put: 'DONT';
		at: (IAC					_ 255)	put: 'IAC'.				"Interpret As Command"
	(Options _ IdentityDictionary new)
		at: (Echo				_ 1)		put: 'ECHO';
		at: (SuppressGoAhead	_ 3)		put: 'SUPPRESS-GO-AHEAD';
		at: (Status				_ 5)		put: 'STATUS';
		at: (Logout				_ 18)	put: 'LOGOUT';
		at: (TerminalType		_ 24)	put: 'TERMINAL-TYPE';
		at: (NAWS				_ 31)	put: 'NAWS';
		at: (TerminalSpeed		_ 32)	put: 'TERMINAL-SPEED';
		at: (RemoteFlowControl	_ 33)	put: 'REMOTE-FLOW-CONTROL';
		at: (Linemode			_ 34)	put: 'LINEMODE';
		at: (XDisplayLocation	_ 35)	put: 'X-DISPLAY-LOCATION';
		at: (EnvironmentOption	_ 36)	put: 'ENVIRONMENT-OPTION';
		at: (NewEnvironment	_ 39)	put: 'NEW-ENVIRONMENT';
		at: (SuppressLocalEcho	_ 45)	put: 'SUPPRESS-LOCAL-ECHO';
		at: (ForwardX			_ 49)	put: 'FORWARD-X'.
	(Subnegotiation _ IdentityDictionary new)
		at: (Is					_ 0)		put: 'IS';
		at: (Send				_ 1)		put: 'SEND'.! !

!TelnetProtocol class methodsFor: 'class initialization'!
initializeProtocol
	"TelnetProtocol initialize"

	| desc |
	desc _ StatefulProtocolDescription initialState: #relax.

	(desc newState: #relax				-> (#passUp:						-> nil))
		add: IAC							-> (nil							-> #iac).

	(desc newState: #iac					-> (#iacIgnored:					-> #relax))
		add: Do							-> (nil							-> #iacDo);
		add: Dont						-> (nil							-> #iacDont);
		add: Will						-> (nil							-> #iacWill);
		add: SB							-> (nil							-> #iacSB);
		add: DataMark					-> (#iacDataMark:				-> #relax)";
		add: Nop						-> (#iacNop:						-> #relax);
		add: Wont						-> (nil							-> #iacWont);
		add: IAC							-> (#iacIAC:						-> #relax)".

	(desc newState: #iacDo				-> (#iacDo:						-> #relax))
		add: Echo						-> (#iacDoEcho:					-> #relax);
		add: TerminalType				-> (#iacDoTerminalType:			-> #relax);
		add: NAWS						-> (#iacDoNAWS:					-> #relax);
		add: TerminalSpeed				-> (#iacDoTerminalSpeed:			-> #relax);
		add: RemoteFlowControl			-> (#iacDoFlowControl:			-> #relax);
		add: XDisplayLocation			-> (#iacDoXDisplay:				-> #relax);
		add: EnvironmentOption			-> (#iacDoEnvironmentOpt:		-> #relax);
		add: NewEnvironment			-> (#iacDoNewEnvironment:		-> #relax).

	(desc newState: #iacDont				-> (#iacDont:					-> #relax))
		add: NAWS						-> (#iacDontNAWS:				-> #relax).

	(desc newState: #iacWill				-> (#iacWill:						-> #relax))	
		add: Echo						-> (#iacWillEcho:				-> #relax);
		add: SuppressGoAhead			-> (#iacWillSuppressGoAhead:	-> #relax).

	"xxx THE FOLLOWING SHOULD BE GENERIC WITH SB ARG ACCUMULATOR VIZ TERM EMU xxx"

	(desc newState: #iacSB				-> (#iacSB:						-> #relax))
		add: TerminalType				-> (nil							-> #sbTermType).

	(desc newState: #sbTermType		-> (nil							-> #relax))
		add: Send						-> (nil							-> #sbTermTypeSend).

	(desc newState: #sbTermTypeSend	-> (nil							-> #relax))
		add: IAC							-> (nil							-> #sbTermTypeSendIAC).

	(desc newState: #sbTermTypeSendIAC	-> (nil							-> #relax))
		add: SE							-> (#sbTerminalTypeSend:		-> #relax).

	States _ desc compile! !

!TelnetProtocol class methodsFor: 'instance creation'!
new
	"TelnetProtocol new"

	^super new initialState: States! !

!TelnetProtocol class methodsFor: 'accessing'!
debug

	^Debug! !

!TelnetProtocol class methodsFor: 'accessing'!
toggleDebugging

	Debug _ Debug not! !

!TelnetProtocol class methodsFor: 'menu'!
buildOptionsMenu

	| m |
	m _ MenuMorph new defaultTarget: self.
	self menu: m add: 'show options processing' var: Debug eval: [Debug _ Debug not]
			help: 'Dispay telnet options negotiation.'.
	self menu: m add: 'print network data' var: DumpNetData eval: [DumpNetData _ DumpNetData not]
			help: 'Dispay raw network data.'.
	self menu: m add: 'print terminal data' var: DumpTermData eval: [DumpTermData _ DumpTermData not]
			help: 'Dispay raw terminal data.'.
	^m! !

!TelnetProtocol class methodsFor: 'menu'!
menu: aMenu add: aString var: aBoolean eval: aBlock help: helpString

	aMenu
		add: (aBoolean ifTrue: ['<yes>'] ifFalse: ['<no>']), aString
		selector: #menuBlock:
		argument: aBlock;
		balloonTextForLastItem: helpString! !

!TelnetProtocol class methodsFor: 'menu'!
menuBlock: aBlock

	aBlock value! !


!VT102Emulator methodsFor: 'initialize-release'!
initialState: aState

	super initialState: aState.
	arguments _ nil.
	trace _ false.
	mode _ #vt52.
	keypadMode _ #normal.
	cursorState _ nil.
	g0Map _ g1Map _ CharsUS.
	charMap _ g0Map.
	keyMap _ IdentityDictionary new.
	self setCursorKeysNormal! !

!VT102Emulator methodsFor: 'initialize-release'!
initialize! !

!VT102Emulator methodsFor: 'initialize-release'!
window: aWindow

	window _ aWindow.
	window setAutoLinefeed: false! !

!VT102Emulator methodsFor: 'arguments'!
addArgument: arg

	arguments
		at: arguments size
		put: (arguments last * 10 + (arg - $0 asInteger))! !

!VT102Emulator methodsFor: 'arguments'!
clearArguments: arg

	arguments _ OrderedCollection with: 0! !

!VT102Emulator methodsFor: 'arguments'!
newArgument: arg

	arguments addLast: 0! !

!VT102Emulator methodsFor: 'arguments'!
oneArgument: arg

	arguments _ arg! !

!VT102Emulator methodsFor: 'control characters'!
bel: arg
	"ring keyboard bell"

	self traceControl: 'BEL'.
	Smalltalk beep! !

!VT102Emulator methodsFor: 'control characters'!
bs: arg
	"backspace"

	self traceControl: 'BS'.
	mode == #vt52
		ifTrue: [window cursorLeft: 1 wrapping: false]
		ifFalse: [window bs]! !

!VT102Emulator methodsFor: 'control characters'!
cr: arg
	"carriage return"

	self traceControl: 'CR'.
	window cr! !

!VT102Emulator methodsFor: 'control characters'!
ht: arg
	"horizontal tab"

	self traceControl: 'HT'.
	window tab! !

!VT102Emulator methodsFor: 'control characters'!
lf: arg
	"linefeed (also formfeed and vertical tab)"

	self traceControl: 'LF'.
	window lf! !

!VT102Emulator methodsFor: 'control characters'!
si: arg
	"Shift In: select G0 charset"

	charMap _ g0Map! !

!VT102Emulator methodsFor: 'control characters'!
so: arg
	"Shift In: select G1 charset"

	charMap _ g1Map! !

!VT102Emulator methodsFor: 'control sequences'!
cub: arg
	"CUrsor Back"

	| n |
	n _ arguments last max: 1.
	self trace: 'CUB ' with: n.
	window cursorLeft: n wrapping: false.! !

!VT102Emulator methodsFor: 'control sequences'!
cud: arg
	"CUrsor Down"

	| n |
	n _ arguments last max: 1.
	self trace: 'CUD' with: n.
	window cursorDown: n scrolling: false! !

!VT102Emulator methodsFor: 'control sequences'!
cuf: arg
 
	| n |
	n _ arguments last max: 1.
	self trace: 'CUF ' with: n.
	window cursorRight: n wrapping: false.! !

!VT102Emulator methodsFor: 'control sequences'!
cup: arg
	"CUrsor Position"
	"Note: this is identical to HVP"

	| x y |
	arguments size == 2
		ifTrue:
			[y _ arguments first max: 1.
			 x _ arguments last max: 1]
		ifFalse:
			[x _ y _ 1].
	self trace: 'CUP ' with: x with: y.
	window activePosition: x@y.! !

!VT102Emulator methodsFor: 'control sequences'!
cuu: arg
	"CUrsor Up"

	| n |
	n _ arguments last max: 1.
	self trace: 'CUU' with: n.
	window cursorUp: n scrolling: false! !

!VT102Emulator methodsFor: 'control sequences'!
dch: arg
	"Delete CHaracter"

	| n |
	n _ (arguments at: 1 ifAbsent: [1]) max: 1.
	window deleteForward: n
	! !

!VT102Emulator methodsFor: 'control sequences'!
dl: arg
	"Delete Lines"

	| param |
	param _ arguments last max: 1.
	self trace: 'DL' with: param.
	window deleteLines: param! !

!VT102Emulator methodsFor: 'control sequences'!
ed: arg
	"Erase in Display"

	| param |
	param _ arguments first.
	self trace: 'ED' with: param.
	param == 1 ifTrue: [^window clearScreenLeft].
	param == 2 ifTrue: [^window clearScreen].
	window clearScreenRight.! !

!VT102Emulator methodsFor: 'control sequences'!
el: arg
	"Erase in Line"

	| param |
	param _ arguments last.
	self trace: 'EL' with: param.
	param == 1 ifTrue: [^window clearLineLeft].
	param == 2 ifTrue: [^window clearLine].
	window clearLineRight! !

!VT102Emulator methodsFor: 'control sequences'!
hts: arg
	"VT52: cursor home
	 ANSI: Horizontal Tab Set"

	mode == #vt52
		ifTrue:
			[self trace: '(VT52) HOME'.
			 window activePosition: 1@1]
		ifFalse:
			[self trace: '(ANSI) HTS'.
			 window setTab]! !

!VT102Emulator methodsFor: 'control sequences'!
hvp: arg
	"Horizontal and Vertical Position"
	"Note: this is identical to CUP"

	| x y |
	arguments size == 2
		ifTrue:
			[y _ arguments first max: 1.
			 x _ arguments last max: 1]
		ifFalse:
			[x _ y _ 1].
	self trace: 'HVP ' with: x with: y.
	window activePosition: x@y.! !

!VT102Emulator methodsFor: 'control sequences'!
il: arg
	"Insert Lines"

	| param |
	param _ arguments last max: 1.
	self trace: 'IL' with: param.
	window insertLines: param! !

!VT102Emulator methodsFor: 'control sequences'!
ind: arg
	"INDex"

	mode == #vt52 ifTrue: [^self cul52: arg].
	self trace: 'RI'.
	window cursorDown: 1 scrolling: true! !

!VT102Emulator methodsFor: 'control sequences'!
nel: arg
	"NExt Line"

	self trace: 'NEL'.
	window newline! !

!VT102Emulator methodsFor: 'control sequences'!
ri: arg
	"Reverse Index"

	self trace: 'RI'.
	window cursorUp: 1 scrolling: true! !

!VT102Emulator methodsFor: 'control sequences'!
rm: arg
	"Reset Mode"

	| param |
	param _ arguments at: 1 ifAbsent: [0].
	param == 4	ifTrue: [self trace:	'IRM	(insert-replace mode: replace)'. ^window setInsertMode: false].

	self debug: 'RM' with: param.! !

!VT102Emulator methodsFor: 'control sequences'!
scs0: arg
	"Select Character Set G0"

	| char |
	char _ Character value: arg.
	char == $A	ifTrue: [self trace: 'select G0 UK'.  ^g0Map _ CharsUK].
	char == $B	ifTrue: [self trace: 'select G0 US'.  ^g0Map _ CharsUS].
	char == $0	ifTrue: [self trace: 'select G0 GR'.  ^g0Map _ CharsGR].
	char == $1	ifTrue: [self trace: 'select G0 US'.  ^g0Map _ CharsUS].
	char == $2	ifTrue: [self trace: 'select G0 US'.  ^g0Map _ CharsUS].
	self debug: 'SCS G0' withChar: arg! !

!VT102Emulator methodsFor: 'control sequences'!
scs1: arg
	"Select Character Set G1"

	| char |
	char _ Character value: arg.
	char == $A	ifTrue: [self trace: 'select G1 UK'.  ^g1Map _ CharsUK].
	char == $B	ifTrue: [self trace: 'select G1 US'.  ^g1Map _ CharsUS].
	char == $0	ifTrue: [self trace: 'select G1 GR'.  ^g1Map _ CharsGR].
	char == $1	ifTrue: [self trace: 'select G1 US'.  ^g1Map _ CharsUS].
	char == $2	ifTrue: [self trace: 'select G1 US'.  ^g1Map _ CharsUS].
	self debug: 'SCS G1' withChar: arg! !

!VT102Emulator methodsFor: 'control sequences'!
sgr: arg
	"Select Graphics Rendition"

	arguments do: [:gr | self sgrSingle: gr]! !

!VT102Emulator methodsFor: 'control sequences'!
sgrSingle: arg

	self trace: 'SGR' with: arg.
	arg == 0 ifTrue: [^window resetVideo].
	arg == 1 ifTrue: [^window setEmphasis: 1].
	arg == 4 ifTrue: [^window setEmphasis: 4].
	arg == 5 ifTrue: [^window setEmphasis: 5].
	arg == 7 ifTrue: [^window setEmphasis: 7].		"this is the most common"
	"all others are ignored silently"
	self debug: 'SGR ', arg printString! !

!VT102Emulator methodsFor: 'control sequences'!
sm: arg
	"Set Mode"

	| param |
	param _ arguments at: 1 ifAbsent: [0].
	param == 4	ifTrue: [self trace:	'IRM	(insert-replace mode: insert)'. ^window setInsertMode: true].

	self debug: 'SM' with: param.! !

!VT102Emulator methodsFor: 'control sequences'!
stbm: arg
	"Set Top and BottoM lines"

	| top bottom |
	top _ 1.
	bottom _ window rows.
	arguments size == 2
		ifTrue:
			[top _ arguments first max: 1.
			 bottom _ arguments last min: bottom].
	self trace: 'STBM' with: top with: bottom.
	top < bottom ifTrue: [window setScrollRegionTop: top bottom: bottom; activePosition: 1@1]! !

!VT102Emulator methodsFor: 'control sequences'!
tbc: arg
	"TaB Clear"

	| n |
	n _ arguments last.
	self trace: 'TBC' with: n.
	n == 0 ifTrue: [^window clearTab].
	n == 3 ifTrue: [^window clearTabs].
	self trace: 'TBC' with: n.! !

!VT102Emulator methodsFor: 'control sequences-VT52'!
ansi52: arg
	"enter ANSI mode"

	self trace: '(VT52) ANSI'.
	self setMode: #ansi! !

!VT102Emulator methodsFor: 'control sequences-VT52'!
cud52: arg
	"VT52: CUrsor Down"

	mode == #ansi ifTrue: [^self debug: 'ESC B'].
	self trace: '(VT52) CUD'.
	window cursorDown: 1 scrolling: false! !

!VT102Emulator methodsFor: 'control sequences-VT52'!
cul52: arg
	"VT52: CUrsor Left"

	mode == #ansi ifTrue: [^self debug: 'ESC D'].
	self trace: '(VT52) CUL'.
	window cursorLeft: 1 wrapping: false! !

!VT102Emulator methodsFor: 'control sequences-VT52'!
cur52: arg
	"VT52: CUrsor Right"

	mode == #ansi ifTrue: [^self debug: 'ESC C'].
	self trace: '(VT52) CUR'.
	window cursorRight: 1 wrapping: false! !

!VT102Emulator methodsFor: 'control sequences-VT52'!
cuu52: arg
	"VT52: CUrsor Up"

	mode == #ansi ifTrue: [^self debug: 'ESC A'].
	self trace: '(VT52) CUU'.
	window cursorUp: 1 scrolling: false! !

!VT102Emulator methodsFor: 'control sequences-VT52'!
dca52: arg
	"VT52: Direct Cursor Adress"
	"The manual probably says what to do with unhandled VT52 sequences
	 when in ANSI mode but I'm too lazy to wade through it today.  Just barf
	 it onto the Transcript for now."

	| line col |
	mode == #ansi ifTrue: [^self debug: 'ESC Y' withChar: arguments withChar: arg].
	line _ arguments - 8r037.
	col _ arg - 8r037.
	self trace: '(VT52) DCA' with: col@line.
	window activePosition: col@line! !

!VT102Emulator methodsFor: 'control sequences-VT52'!
ed52: arg
	"VT52: Erase to end of Display"

	mode == #ansi ifTrue: [^self debug: 'ESC J'].
	self trace: '(VT52) ED'.
	window clearScreenRight! !

!VT102Emulator methodsFor: 'control sequences-VT52'!
egm52: arg
	"VT52: Enter Graphics Mode"

	mode == #ansi ifTrue: [^self debug: 'ESC F'].
	self trace: '(VT52) EGM'.
	charMap _ CharsGR! !

!VT102Emulator methodsFor: 'control sequences-VT52'!
el52: arg
	"VT52: Erase to end of Line"

	mode == #ansi ifTrue: [^self debug: 'ESC K'].
	self trace: '(VT52) EL'.
	window clearLineRight! !

!VT102Emulator methodsFor: 'control sequences-VT52'!
lgm52: arg
	"VT52: Leave Graphics Mode"

	mode == #ansi ifTrue: [^self debug: 'ESC G'].
	self trace: '(VT52) LGM'.
	charMap _ CharsUS! !

!VT102Emulator methodsFor: 'control sequences-VT52'!
rlf52: arg
	"VT52: Reverse Line Feed"

	mode == #ansi ifTrue: [^self debug: 'ESC I'].
	self trace: '(VT52) RLF'.
	window cursorUp: 1 scrolling: true! !

!VT102Emulator methodsFor: 'control sequences-DEC'!
decid: arg
	"DEC IDentify terminal (what are you?)"
	"Note: the response is the same regardless of the operating mode: we send `ESC / Z'
	 which identifies us as a VT102."

	self trace: 'DECID -> ESC / Z'.
	down
		downcall: Character escape asInteger;
		downcall: $/ asInteger;
		downcall: $Z asInteger! !

!VT102Emulator methodsFor: 'control sequences-DEC'!
decla: arg
	"DEC Line Attributes"

	arg == 16r33 ifTrue: [^self debug: 'DECDHL (hi)'].
	arg == 16r34 ifTrue: [^self debug: 'DECDHL (lo)'].
	arg == 16r35 ifTrue: [^self debug: 'DECSWL'].
	arg == 16r36 ifTrue: [^self debug: 'DECDWL'].
	arg == 16r38 ifTrue: [self trace: 'DECALN (alignment test)'. ^window fillScreen: $E].
	self debug: 'ESC #' withChar: arg.! !

!VT102Emulator methodsFor: 'control sequences-DEC'!
decpam: arg
	"DEC keyPad Application Mode"

	self trace: 'DECPNM'.
	self flag: #ikp.	"ignored for now -- since I don't have a keypad. ;-)"! !

!VT102Emulator methodsFor: 'control sequences-DEC'!
decpnm: arg
	"DEC keyPad Normal Mode"

	self trace: 'DECPNM'.
	self flag: #ikp.	"ignored for now -- since I don't have a keypad. ;-)"! !

!VT102Emulator methodsFor: 'control sequences-DEC'!
decrc: arg
	"DEC private Restore Cursor"

	cursorState isNil ifFalse:
		[window
			activePosition:	(cursorState at: 1);
			graphicsState:	(cursorState at: 2).
		 charMap _ cursorState at: 3]! !

!VT102Emulator methodsFor: 'control sequences-DEC'!
decrm: arg
	"DEC private Reset Mode"

	arguments do: [:param | self decrmSingle: param]! !

!VT102Emulator methodsFor: 'control sequences-DEC'!
decrmSingle: param
	"DEC private Reset Mode"

	param == 1	ifTrue: [self trace:		'DECCKM		(cursor key mode: cursor)'.  ^self setCursorKeysNormal].
	param == 2	ifTrue: [self trace:		'DECANM	(ansi mode: VT52)'.  ^self setMode: #vt52].
	param == 3	ifTrue: [self trace:		'DECCOLM	(column mode: 80)'. ^window setWidth: 80].
	param == 4	ifTrue: [self trace:		'DECSCLM	(scroll mode: jump)'.  ^window setSmoothScroll: false].
	param == 5	ifTrue: [self trace:		'DECSCNM	(screen mode: normal)'.  ^window rv: false].
	param == 6	ifTrue: [self trace:		'DECOM		(origin mode: absolute)'. ^window setRelativeOrigin: false; activePosition: 1@1].
	param == 7	ifTrue: [self trace:		'DECAWM	(autowrap mode: off)'. ^window setAutoWrap: false].
	param == 8	ifTrue: [^self trace:		'DECARM	(autorepeat mode: off)'].
	param == 18	ifTrue: [^self trace:		'DECPFF		(print FF: off)'].
	param == 19	ifTrue: [^self trace:		'DECPEX		(print extent: region)'].
	"Emacs somtimes sends this.  Ho hum..."
	param == 25	ifTrue: [^window setShowCursor: false].

	self debug: 'DECRM' with: param.! !

!VT102Emulator methodsFor: 'control sequences-DEC'!
decsc: arg
	"DEC private Save Cursor"

	(cursorState _ Array new: 3)
		at: 1 put: window activePosition;
		at: 2 put: window graphicsState;
		at: 3 put: charMap! !

!VT102Emulator methodsFor: 'control sequences-DEC'!
decsm: arg
	"DEC private Set Mode"

	arguments do: [:param | self decsmSingle: param]! !

!VT102Emulator methodsFor: 'control sequences-DEC' stamp: 'ikp 2/18/2003 23:01'!
decsmSingle: param
	"DEC private Set Mode"

	param == 1	ifTrue: [self trace:		'DECCKM		(cursor key mode: application)'. ^self setCursorKeysApplication].
	param == 2	ifTrue: [self trace:		'DECANM	(ansi mode: ANSI)'.  ^self setMode: #ansi].
	param == 3	ifTrue: [self trace:		'DECCOLM	(column mode: 132)'. ^window setWidth: 132].
	param == 4	ifTrue: [self trace:		'DECSCLM	(scroll mode: smooth)'.  ^window setSmoothScroll: true].
	param == 5	ifTrue: [self trace:		'DECSCNM	(screen mode: reverse)'.  ^window rv: true].
	param == 6	ifTrue: [self trace:		'DECOM		(origin mode: relative)'. ^window setRelativeOrigin: true; activePosition: 1@1].
	param == 7	ifTrue: [self trace:		'DECAWM	(autowrap mode: on)'. ^window setAutoWrap: true].
	param == 8	ifTrue: [^self trace:		'DECARM	(autorepeat mode: on)'].
	param == 18	ifTrue: [^self trace:		'DECPFF		(print FF: on)'].
	param == 19	ifTrue: [^self trace:		'DECPEX		(print extent: screen)'].
	"Emacs somtimes sends this.  Ho hum..."
	param == 25	ifTrue: [^window setShowCursor: true].

	self debug: 'DECSM' with: param.! !

!VT102Emulator methodsFor: 'identification'!
terminalTypeString
	"Viz: RFCs 930 (Telnet Terminal Type Option) and 1700 (Assigned Numbers)"

	^'VT102'! !

!VT102Emulator methodsFor: 'protocol'!
downcall: arg
	"Translate Squeak special keys into VT100 control sequences."

	(keyMap includesKey: arg)
		ifTrue: [down downcallAll: (keyMap at: arg)]
		ifFalse: [down downcall: (arg bitAnd: 127)]! !

!VT102Emulator methodsFor: 'protocol'!
install

	super install.
	session propertyAt: #terminalType put: self terminalTypeString! !

!VT102Emulator methodsFor: 'protocol'!
passUp: arg

	super passUp: (charMap at: arg + 1)! !

!VT102Emulator methodsFor: 'protocol'!
run

	super run.
	window _ session
		propertyAt: #window
		ifAbsent: [^self error: 'Terminal emulators require a window in their protocol stack']! !

!VT102Emulator methodsFor: 'private'!
csi: arg

	self debug: 'CSI' withAll: arguments withChar: arg! !

!VT102Emulator methodsFor: 'private'!
debug: message

	Transcript nextPutAll: '*** '; nextPutAll: message; cr; endEntry! !

!VT102Emulator methodsFor: 'private'!
debug: message with: arg

	Transcript
		nextPutAll: '*** ';
		nextPutAll: message; space;
		print: arg; cr;
		endEntry! !

!VT102Emulator methodsFor: 'private'!
debug: message withAll: args withChar: char

	Transcript
		nextPutAll: '*** ';
		nextPutAll: message; space.
	args do: [:a | Transcript print: a; space].
	Transcript
		print: char asCharacter; space;
		nextPut: $(; print: char; nextPut: $); cr;
		endEntry.! !

!VT102Emulator methodsFor: 'private'!
debug: message withChar: char

	Transcript
		nextPutAll: '*** ';
		nextPutAll: message; space;
		print: char asCharacter; space;
		nextPut: $(; print: char; nextPut: $); cr;
		endEntry.! !

!VT102Emulator methodsFor: 'private'!
debug: message withChar: a withChar: b

	Transcript
		nextPutAll: '*** ';
		nextPutAll: message; space;
		print: a asCharacter; space;
		print: b asCharacter; space;
		nextPut: $(; print: a; space; print: b; nextPut: $); cr;
		endEntry.! !

!VT102Emulator methodsFor: 'private'!
dec: arg

	self debug: 'CSI ?' withAll: arguments withChar: arg! !

!VT102Emulator methodsFor: 'private'!
esc: arg

	self debug: 'ESC' withChar: arg! !

!VT102Emulator methodsFor: 'private' stamp: 'ikp 2/18/2003 23:04'!
setCursorKeysApplication

	| esc |
	esc _ Character escape asString.
	keyMap
		at: 128+28 put: (esc,'OD') asByteArray;		"left"
		at: 128+29 put: (esc,'OC') asByteArray;		"right" 
		at: 128+30 put: (esc,'OA') asByteArray;		"up"
		at: 128+31 put: (esc,'OB') asByteArray.		"down" ! !

!VT102Emulator methodsFor: 'private'!
setCursorKeysNormal

	| esc |
	esc _ Character escape asString.
	keyMap
		at: 128+28 put: (esc,'[D') asByteArray;		"left"
		at: 128+29 put: (esc,'[C') asByteArray;		"right" 
		at: 128+30 put: (esc,'[A') asByteArray;		"up"
		at: 128+31 put: (esc,'[B') asByteArray.		"down" ! !

!VT102Emulator methodsFor: 'private'!
setMode: aSymbol

	mode _ aSymbol.! !

!VT102Emulator methodsFor: 'private'!
trace: message

	trace ifTrue: [Transcript nextPutAll: message; cr; endEntry]! !

!VT102Emulator methodsFor: 'private'!
trace: message with: a

	trace ifTrue: [Transcript nextPutAll: message; space; print: a; cr; endEntry]! !

!VT102Emulator methodsFor: 'private'!
trace: message with: a with: b

	trace ifTrue: [Transcript nextPutAll: message; space; print: a; space; print: b; cr; endEntry]! !

!VT102Emulator methodsFor: 'private'!
traceControl: message

	trace ifTrue: [Transcript nextPutAll: message; cr; endEntry]! !


!VT102Emulator class methodsFor: 'class initialization'!
initialize
	"VT102Emulator initialize"

	"protocol"
	States _ self protocol compile.

	"character sets"
	CharsUK _ Array new: 256.
	CharsUS _ Array new: 256.
	CharsGR _ Array new: 256.
	1 to: 256 do: [:i | CharsUK at: i put: (CharsUS at: i put: (CharsGR at: i put: i - 1))].
	1 to: 32 do: [:i | CharsGR at: i + 95 put: (CharsGR at: i)].
	CharsUK at: ($# asInteger + 1) put: (CharsGR at: 31)! !

!VT102Emulator class methodsFor: 'class initialization'!
protocol

	| desc |
	desc _ StatefulProtocolDescription initialState: #relax.

	"Default: pass everything up except DEL, ESC and ASCII control chars (see end)"
	(desc newState: #relax	-> (#passUp:		-> nil))
		add: 8r033			-> (nil			-> #esc);	"ANSI or CSI"
		add: 8r177			-> (nil			-> nil).		"ignored on input"

	"ESC -- either ANSI control sequence, DEC private or first char of CSI"
	(desc newState: #esc		-> (#esc: 				-> #relax))
		addInteger: $#		-> (nil					-> #decla);	"line attributes"
		addInteger: $<		-> (#ansi52:				-> #relax);	"ansi mode"
		addInteger: $>		-> (#decpnm:			-> #relax);	"normal keypad mode"
		addInteger: $=		-> (#decpam:			-> #relax);	"application keypad mode"
		addInteger: $(		-> (nil					-> #scs0);	"select G0 character set"
		addInteger: $)		-> (nil					-> #scs1);	"select G1 character set"
		addInteger: $7		-> (#decsc:				-> #relax);	"save cursor"
		addInteger: $8		-> (#decrc:				-> #relax);	"restore cursor"
		addInteger: $A		-> (#cuu52:				-> #relax);	"VT52: cursor up"
		addInteger: $B		-> (#cud52:				-> #relax);	"VT52: cursor down"
		addInteger: $C		-> (#cur52:				-> #relax);	"VT52: cursor right"
		addInteger: $D		-> (#ind:				-> #relax);	"index (VT52: cursor left)"
		addInteger: $E		-> (#nel:				-> #relax);	"next line"
		addInteger: $F		-> (#egm52:				-> #relax);	"VT52: enter graphics mode"
		addInteger: $G		-> (#lgm52:				-> #relax);	"VT52: leave graphics mode"
		addInteger: $H		-> (#hts:				-> #relax);	"horizontal tab set (VT52: home)"
		addInteger: $I		-> (#rlf52:				-> #relax);	"VT52: reverse line feed"
		addInteger: $J		-> (#ed52:				-> #relax);	"VT52: erase to EOD"
		addInteger: $K		-> (#el52:				-> #relax);	"VT52: erase to EOL"
		addInteger: $M		-> (#ri:					-> #relax);	"reverse index"
		addInteger: $Y		-> (nil					-> #dca1);	"VT52: direct cursor address"
		addInteger: $Z		-> (#decid:				-> #relax);	"what are you?"
		addInteger: $[		-> (#clearArguments:	-> #csi).		"begin CS"

	"ESC # -- dec line attributes"
	(desc newState: #decla	-> (#decla:			-> #relax)).	"line attributes"
	"ESC ( -- SCS for G0 and G1"
	(desc newState: #scs0	-> (#scs0:			-> #relax)).	"select character set for G0"
	(desc newState: #scs1	-> (#scs1:			-> #relax)).	"select character set for G1"
	"ESC Y -- VT52 cursor addressing"
	(desc newState: #dca1	-> (#oneArgument:	-> #dca2)).	"direct cursor address (line)"
	(desc newState: #dca2	-> (#dca52:			-> #relax)).	"direct cursor address (col)"

	"ESC [ -- CSI"
	(desc newState: #csi				-> (#csi:				-> #relax))
		addAllInteger: '0123456789'	-> (#addArgument:	-> nil);
		addInteger: $;				-> (#newArgument:	-> nil);
		addInteger: $?				-> (nil				-> #dec);	"dec private mode"
		addInteger: $=				-> (nil				-> #relax);	"alternate keypad mode"
		addInteger: $A				-> (#cuu:			-> #relax);	"cursor up"
		addInteger: $B				-> (#cud:			-> #relax);	"cursor down"
		addInteger: $C				-> (#cuf:			-> #relax);	"cursor forward"
		addInteger: $D				-> (#cub:			-> #relax);	"cursor backward"
		addInteger: $H				-> (#cup:			-> #relax);	"cursor position"
		addInteger: $J				-> (#ed:				-> #relax);	"erase in display"
		addInteger: $K				-> (#el:				-> #relax);	"erase in line"
		addInteger: $L				-> (#il:				-> #relax);	"insert lines"
		addInteger: $M				-> (#dl:				-> #relax);	"delete lines"
		addInteger: $P				-> (#dch:			-> #relax);	"delete character"
		addInteger: $f				-> (#hvp:			-> #relax);	"horiz and vert pos"
		addInteger: $g				-> (#tbc:			-> #relax);	"tab clear"
		addInteger: $h				-> (#sm:				-> #relax);	"set mode"
		addInteger: $l				-> (#rm:				-> #relax);	"reset mode"
		addInteger: $m				-> (#sgr:			-> #relax);	"select graphic rendition"
		addInteger: $r				-> (#stbm:			-> #relax).	"set top/bottom"

	"CSI ? -- DEC private mode change"
	(desc newState: #dec				-> (#dec: 			-> #relax))
		addAllInteger: '0123456789'	-> (#addArgument:	-> nil);
		addInteger: $;				-> (#newArgument:	-> nil);
		addInteger: $h				-> (#decsm:			-> #relax);	"set mode"
		addInteger: $l				-> (#decrm:			-> #relax).	"reset mode"

	"ASCII control characters are interpreted immediately during ESC, CSI and DEC"
	#(esc csi dec relax) do: [:mode | (desc at: mode)
		add: 8r000	-> (nil		-> nil);	"NUL: ignored on input"
		add: 8r007	-> (#bel:	-> nil);	"Note: this is an OSC delimiter in XTerm"
		add: 8r010	-> (#bs:		-> nil);
		add: 8r011	-> (#ht:		-> nil);
		add: 8r012	-> (#lf:		-> nil);
		add: 8r013	-> (#lf:		-> nil);	"VT interpreted as LF"
		add: 8r014	-> (#lf:		-> nil);	"FF interpreted as LF"
		add: 8r015	-> (#cr:		-> nil);	"FF interpreted as LF"
		add: 8r016	-> (#so:		-> nil);	"shift out: select G0 charset"
		add: 8r017	-> (#si:		-> nil)].	"shift in: select G1 charset"

	"That's it folks.  (Simple when you look at it like this, no? ;-)"
	^desc! !

!VT102Emulator class methodsFor: 'instance creation'!
new
	"VT100Emulator new"

	^super new initialize initialState: States! !

!VT102Emulator class methodsFor: 'accessing'!
terminalTypeName

	^'vt102'! !


!XtermEmulator methodsFor: 'initialize-release'!
initialize

	super initialize.
	savedBuffer _ nil! !

!XtermEmulator methodsFor: 'identification'!
terminalTypeString
	"Viz: RFCs 930 (Telnet Terminal Type Option) and 1700 (Assigned Numbers)"

	^'XTERM'! !

!XtermEmulator methodsFor: 'control sequences'!
cha: arg
	"Character Position Absolute"

	self trace: 'CHA ' , (arguments first max: 1) printString.
	window activeColumn: (arguments first max: 1)! !

!XtermEmulator methodsFor: 'control sequences'!
dch: arg
	"Delete Character(s)"

	| n |
	n _ (arguments at: 1 ifAbsent: [1]) max: 1.
	window deleteForward: n
	! !

!XtermEmulator methodsFor: 'control sequences'!
decrmSingle: param

	self trace: 'DECSM' with: param.
	param == 1047 ifTrue: [^self restoreBuffer].
	param == 1048 ifTrue: [^self restoreState].
	param == 1049 ifTrue: [^self restoreBuffer; restoreState.].
	super decrmSingle: param! !

!XtermEmulator methodsFor: 'control sequences'!
decsmSingle: param

	self trace: 'DECSM' with: param.
	param == 1047 ifTrue: [^self saveBuffer].
	param == 1048 ifTrue: [^self saveState].
	param == 1049 ifTrue: [self saveState; saveBuffer. ^window clearScreen; activePosition: 1@1].
	super decsmSingle: param! !

!XtermEmulator methodsFor: 'control sequences'!
ich: arg
	"Insert Character(s)"

	| n |
	n _ (arguments at: 1 ifAbsent: [1]) max: 1.
	self trace: 'ICH ' , n printString.
	window insert: n
	! !

!XtermEmulator methodsFor: 'control sequences'!
il: arg
	"Insert Line(s)"

	| n |
	n _ (arguments at: 1 ifAbsent: [1]) max: 1.
	window insertLines: n
	! !

!XtermEmulator methodsFor: 'control sequences'!
lpa: arg
	"Line Position Absolute"

	| y x |
	y _ 1.
	x _ window activeColumn.
	arguments size > 0 ifTrue: [y _ arguments first].
	arguments size > 1 ifTrue: [x _ arguments at: 2].
	window activePosition: x@y! !

!XtermEmulator methodsFor: 'control sequences'!
osc: arg
	"Operating System Command"

	| type |
	type _ arguments first.
	(type == 0 or: [type == 1]) ifTrue: [window setIconTitle: arguments last].
	(type == 0 or: [type == 2]) ifTrue: [window setWindowTitle: arguments last].
	"All others are silently ignored"! !

!XtermEmulator methodsFor: 'control sequences'!
sgrSingle: arg

	self trace: 'SGR' with: arg.
	"ANSI colour codes"
	arg == 24 ifTrue: [^window setEmphasis: 4 to: 0].
	arg == 25 ifTrue: [^window setEmphasis: 5 to: 0].
	arg == 27 ifTrue: [^window setEmphasis: 7 to: 0].
	(arg >= 30 and: [arg <= 37]) ifTrue: [^window setForeground: arg - 30].
	arg == 39 ifTrue: [^window setForeground: 0].
	(arg >= 40 and: [arg <= 47]) ifTrue: [^window setBackground: arg - 40].
	arg == 49 ifTrue: [^window setBackground: 7].
	super sgrSingle: arg! !

!XtermEmulator methodsFor: 'arguments'!
addStringArgument: arg

	arguments
		at: arguments size
		put: (arguments last , (String with: arg asCharacter))! !

!XtermEmulator methodsFor: 'arguments'!
newStringArgument: arg

	arguments addLast: ''! !

!XtermEmulator methodsFor: 'private'!
restoreBuffer
	"Restore the tty to its previously saved state."

	savedBuffer isNil ifFalse: [window bufferState: savedBuffer].
	window setEmacsColours: false! !

!XtermEmulator methodsFor: 'private'!
restoreState
	"Pretend we saw Restore Cursor"

	^self decrc: nil! !

!XtermEmulator methodsFor: 'private'!
saveBuffer
	"Save a copy of the current state of the tty."

	savedBuffer _ window bufferState.
	window setEmacsColours: true! !

!XtermEmulator methodsFor: 'private'!
saveState
	"Pretend we saw Save Cursor"

	^self decsc: nil! !

!XtermEmulator methodsFor: 'protocol'!
note: aSymbol with: anObject

	super note: aSymbol with: anObject.
	aSymbol == #endpointClosed ifTrue: [^self restoreBuffer].! !


!XtermEmulator class methodsFor: 'class initialization'!
initialize
	"XtermEmulator initialize"

	super initialize.
	States _ self protocol compile! !

!XtermEmulator class methodsFor: 'class initialization'!
protocol
	"XtermEmulator initialize"
	"XTerm is just a glorified VT102."

	| desc |
	desc _ super protocol.	"Vanilla VT102"

	"Additional control sequences"
	(desc at: #csi)
		addInteger:		$@			-> (#ich:					-> #relax);	"insert character"
		addInteger:		$d			-> (#lpa:					-> #relax);	"line position abs"
		addInteger:		$G			-> (#cha:					-> #relax);	"char position abs"
		addInteger:		$L			-> (#il:						-> #relax);	"insert line(s)"
		addInteger:		$P			-> (#dch:					-> #relax).	"delete character(s)"

	"Operating system commands"
	(desc at: #esc)
		addInteger:		$]			-> (#clearArguments:		-> #csix).

	"Xterm CSI has a numeric prefix delimited by `;' and textual suffix delimited by BEL"
	(desc newState:		#csix		-> (nil						-> nil))	"ignore everything except..."
		addAllInteger:	'0123456789'	-> (#addArgument:			-> nil);
		addInteger:		$;			-> (#newStringArgument:	-> #csix2);
		add:				8r007		-> (nil						-> #relax).	"premature BEL"

	(desc newState:		#csix2		-> (#addStringArgument:		-> nil))		"eat everything except..."
		add:				8r007		-> (#osc:					-> #relax).	"OSC complete"
	^desc! !

!XtermEmulator class methodsFor: 'instance creation'!
new
	"XtermEmulator new"

	^super new initialState: States! !

!XtermEmulator class methodsFor: 'accessing'!
terminalTypeName

	^'xterm'! !

XtermEmulator initialize!
VT102Emulator initialize!
TelnetProtocol initialize!
TeletypeWindow initialize!
TeletypeMorph initialize!
SimpleTextMorph initialize!
SafeSocket initialize!