$TYPECHECK ON

'### MULTI LEVEL UNDO/REDO BOX VERSION 1.0a ###'

CONST CR$ = chr$(13):CONST LF$ = chr$(10)
CONST NEWLINE$ = chr$(13)+chr$(10):CONST DbQUOTE = chr$(34) '-- charactor
CONST NONE_KEY = 0:CONST GENERAL_KEY = 1: CONST PASTE_KEY = 2
CONST VK_A = 65:CONST VK_Z = 90
CONST VK_SEMICOLON = 186:CONST VK_SLASH = 191
CONST VK_LBRACKET = 219:CONST VK_SINGLEQUOTE = 222
CONST VK_NUM0 = 48:CONST VK_NUM9 = 57 '-- Private_VK
CONST VK_TAB = &H9:CONST VK_RETURN = &HD:CONST VK_SPACE = &H20
CONST VK_BACK = &H8:CONST VK_DELETE = &H2E
CONST VK_NUMPAD0 = &H60:CONST VK_NUMPAD9 = &H69
CONST VK_MULTIPLY = &H6A:CONST VK_DIVIDE = &H6F '-- Win32Api_VK

'// ABOUT PROGRAM '//
declare sub about_close

create about as qform
	caption = "about this program"
	height = 200
	create aboutbox as qrichedit
	align = 1
	alignment = 2
	readonly = 1
	height = 110
	text = "UNDO/REDO BOX VERSION 1.0a"+NEWLINE$+_
	"Program by Suchart Chokphichitchai"+NEWLINE$+NEWLINE$+_
	"Copy Right 2003-2004"
	end create
	create aboutbtn as qbutton
	top = aboutbox.height+5
	left = 110
	caption = "close"
	onclick = about_close
	end create
end create

sub about_close
	about.close
end sub

sub aboutShow
	about.center
	about.showmodal
end sub

'// OBJECT DECLARATION //
DIM Form AS QForm
    Form.Center
DIM mn AS QMainMenu
	DIM iEdit AS QMenuItem
		DIM iRedo AS QMenuItem
		DIM iUndo AS QMenuItem
		DIM iDelWord AS QMenuItem
		DIM iBackWord AS QMenuItem
		DIM iCut AS QMenuItem
		DIM iCopy AS QMenuItem
		DIM iPaste AS QMenuItem
		DIM iSelAll AS QMenuItem
		DIM iEditMode AS QMenuItem
	DIM iHelp AS QMenuItem
		DIM iAbout AS QMenuItem
DIM ed AS QRichEdit
DIM LsVal AS QListbox
Dim LsUndoIndex AS QListbox
Dim ls AS QListbox
Dim lsN AS QListbox

const dmnCount = 7 ' truely = 8
defstr deliminator(dmnCount) = {" ", ".", ",", ":", ";", chr$(9),CR$,LF$}
dim DownKey as integer
dim DownShift as integer
dim selBegin as integer
dim Lspace as integer
dim Rspace as integer
dim Deleted as string
defint TextCount = 0 '// keep Len(Ed.Text) By OnKeydown Event, And Edit-Subroutine
defint undoPosition = -1


'// FUNCTION AND EVENT //
sub showUndoPosition '-- Global Purpose
'-- this  Subroutine need not for Undoing --'
 ' It's just show the proceed of command.
 ' You may insert quote-mark infront of it to run faster.
	LsUndoIndex.itemIndex = undoPosition
	Ls.itemIndex = undoPosition
	LsN.itemIndex = undoPosition
end sub

subi intVar(...) '// for showVariable
	dim i as integer
	if paramValCount<>paramStrCount then
	LsVal.Additems "wrong parameter amount"
	LsVal.Additems str$(paramValCount)+" "+str$(paramStrCount)
	else
		for i = 1 to paramValCount
			LsVal.Additems paramStr$(i)+" = "+str$(paramVal(i))
		next i
	end if
	LsVal.itemIndex = LsVal.itemCount - 1
end subi

subi strVar(...) '// for showVariable
	dim i as integer
	if (paramStrCount mod 2 <> 0) then
	LsVal.Additems "wrong parameter amount"
	LsVal.Additems str$(paramValCount)+" "+str$(paramStrCount)
	else
		for i = 1 to paramStrCount step 2
			LsVal.Additems paramStr$(i)+" = "+DbQUOTE+paramStr$(i+1)+DbQUOTE
		next i
	end if
	LsVal.itemIndex = LsVal.itemCount-1
end subi

sub Inc_undoPosition
	undoPosition = undoPosition + 1
end sub

sub Dec_undoPosition
	undoPosition = undoPosition - 1
end sub

function LMarkDistance( sel as integer ) as integer
defint LenText = Len(Ed.Text)
defint sel_first = sel
dim i as integer
	while ( sel > 0 ) '// sound is hard-work, but at for-loop have condition
	'// will stop while loop when found deliminator(i)
		for i = 0 to dmnCount
			if (Ed.Text[ sel ] = deliminator(i)) then
				exit while
			end if
		next i
		sel = sel - 1
	wend
	if (sel = sel_first) then '// if found deliminator at first time.
	'// purpose find length of same-deliminator char.
		while (sel > 0 )
			sel = sel - 1 ' obtain it decrease.
			if (Ed.Text[ sel ] <> deliminator(i)) then '// when found not-deliminator(i).
				exit while
			end if
		wend
	end if
'// sometime refering to not-exists variable coz mistake.
LMarkDistance = sel_first - sel
end function

function RMarkDistance( sel as integer ) as integer
defint LenText = Len(Ed.Text)
defint sel_first = sel
dim i as integer
	while ( sel < LenText ) '// sound is hard-work, but at for-loop have condition
	'// will stop while loop when found deliminator(i)
		sel = sel + 1
		for i = 0 to dmnCount
			if (Ed.Text[ sel ] = deliminator(i)) then
				sel = sel - 1
				exit while
			end if
		next i
	wend
	if (sel = sel_first) then '// if found deliminator at first time.
	'// purpose find length of same-deliminator char.
		while (sel < LenText)
			sel = sel + 1 ' obtain it increase.
			if (Ed.Text[ sel ] <> deliminator(i)) then '// when found not-deliminator(i).
				sel = sel - 1
				exit while
			end if
		wend
	end if
RMarkDistance = sel - sel_first
end function


sub DelBackHilight
		DownKey = VK_BACK
		selBegin = Ed.SelStart + Ed.selLength 'increase coz SelStart is at left of SelText
		Deleted = Ed.SelText
		TextCount = Len(Ed.Text)	
end sub

sub DelWord
		DownKey = VK_DELETE
		selBegin = Ed.SelStart
		Rspace = IIF(MID$(Ed.Text,Ed.SelStart+1,2) = CR$+LF$, 2, RMarkDistance(Ed.SelStart))
		Deleted = MID$(Ed.Text, Ed.SelStart+1,Rspace) '// keep RightText may deleted.
		TextCount = Len(Ed.Text)
end sub

sub DelBack
		DownKey = VK_BACK
		selBegin = Ed.SelStart
		Lspace = IIF(MID$(Ed.Text,Ed.SelStart-1,2) = CR$+LF$, 2, LMarkDistance(Ed.SelStart))
		Deleted = MID$(Ed.Text, Ed.SelStart - Lspace + 1 , Lspace )
		TextCount = Len(Ed.Text)
end sub

sub edkbdown(Key AS WORD, Shift AS INTEGER)
if (Shift <> 16) then '// purpose = not add undoList when click menu
	SELECT CASE Key
	CASE VK_A TO VK_Z,VK_SEMICOLON TO VK_SLASH,_
	VK_LBRACKET TO VK_SINGLEQUOTE,VK_NUM0 TO VK_NUM9,_
	VK_NUMPAD0 TO VK_NUMPAD9,VK_MULTIPLY TO VK_DIVIDE,VK_SPACE,VK_TAB:
		DownKey = GENERAL_KEY
		selBegin = Ed.SelStart
	CASE VK_BACK:
		if (Ed.selLength <> 0) then ' Del by hilights
			DelBackHilight
		else ' (Ed.SelLength = 0) ' Del by not hilights
			if (Ed.SelStart <> 0) then
				DelBack
			end if
		end if
	CASE VK_RETURN:
		DownKey = VK_RETURN
		selBegin = Ed.SelStart
	CASE VK_DELETE:
		if (Ed.SelStart <> Len(Ed.Text)) then '// not add UndoList if SelStart at last position
			DelWord
		end if
	END SELECT
end if
end sub

sub IF_Not_LastPosition_DelOldList
' When Edit Between Undo/Redo,
'Delete RedoList (All UndoList which above UndoPosition)
'used by OnChange Event
	dim i as integer
	if (undoPosition <> Ls.itemCount-1) then
		for i = Ls.itemCount-1 to undoPosition+1 step -1
			LsUndoIndex.DelItems i ' clear old undoList
			Ls.DelItems i  ' clear old undoList
			LsN.DelItems i ' clear old selStartList
		next i
	end if
end sub

sub addUndoItem( item$ as string, position as integer )
	LsUndoIndex.Additems str$(undoPosition+1) '// For Display UndoIndex
	Ls.Additems item$ '// add undoList
	LsN.Additems str$(position) '// add undoSelStart
	DownKey = NONE_KEY '// set value for protect adding undoList over 1 per time.
end sub

sub edbkbChg
	SELECT CASE DownKey
	CASE GENERAL_KEY:
			IF_Not_LastPosition_DelOldList
			addUndoItem(Ed.Text[Ed.SelStart], selBegin)
			Inc_UndoPosition:	showUndoPosition
	CASE VK_BACK:
			IF_Not_LastPosition_DelOldList
			addUndoItem(right$( Deleted, TextCount-Len(Ed.Text) )+"B", selBegin) 'develop
			Inc_undoPosition:	showUndoPosition
	CASE VK_RETURN:
			IF_Not_LastPosition_DelOldList			
			addUndoItem("#R", selBegin)
			Inc_undoPosition:	showUndoPosition
	CASE VK_DELETE:
			IF_Not_LastPosition_DelOldList
			addUndoItem(left$( Deleted, TextCount-Len(Ed.Text) )+"D", selBegin)
			Inc_undoPosition:	showUndoPosition
	CASE PASTE_KEY:
			IF_Not_LastPosition_DelOldList
			defint LenPasted = Len(Ed.Text) - TextCount
			addUndoItem(Mid$(Ed.Text, Ed.SelStart - LenPasted + 1, LenPasted )+"P", selBegin)
			Inc_undoPosition:	showUndoPosition
	END SELECT
end sub

sub SelStartSelLength(sStart as integer, sLen as integer)
	Ed.SelStart = sStart
	Ed.SelLength = sLen
end sub

sub iUndoCk
	defstr itemType$ = right$(Ls.item(undoPosition),1)
	defint LenUndo = Len(Ls.item(undoPosition))
	defint UndoSelStart = val(LsN.item(undoPosition))
if (LenUndo = 1) then '//GENERAL_KEY
	SelStartSelLength( UndoSelStart, 1)
	Ed.SelText = ""
	Dec_undoPosition:	showUndoPosition
elseif (LenUndo > 1) then
	SELECT CASE itemType$
	CASE "B": 'VK_BACK
			SelStartSelLength( UndoSelStart - Len(Ls.item(undoPosition))+1 , 1)
			Ed.SelText = left$(Ls.item(undoPosition),Len(Ls.item(undoPosition))-1)+Ed.SelText
			Ed.SelStart = UndoSelStart
'			SelCorrectPosition
			Dec_undoPosition:	showUndoPosition
	CASE "R": 'VK_RETURN
			SelStartSelLength( UndoSelStart, 2 )
			Ed.SelText = ""
			Dec_undoPosition:	showUndoPosition
	CASE "D": 'VK_DELETE
			SelStartSelLength( UndoSelStart, 0)
			Ed.SelText = left$(Ls.item(undoPosition),Len(Ls.item(undoPosition))-1)
'			SelCorrectPosition
			Ed.SelStart = UndoSelStart
			Dec_undoPosition:	showUndoPosition
	CASE "P": 'PASTE_KEY
			SelStartSelLength( UndoSelStart, Len(Ls.item(undoPosition))-1)
			Ed.SelText = ""
			Dec_undoPosition:	showUndoPosition
	END SELECT
end if
DownKey = NONE_KEY '// protect onchange event
end sub

sub iRedoCk
	defint redoPosition = undoPosition+1
	defint LenRedo = Len(Ls.item(redoPosition))
	defstr ItemType$ = right$(Ls.item(redoPosition),1)
	defint RedoSelStart = val( LsN.item(redoPosition) )
if (LenRedo = 1) then '// GENERAL_KEY
	' Develop
	defint ascRedo = asc(Ls.item(redoPosition))
	select case ascRedo '// correct re-input my native language.
	case 209 to 218,231 to 237
		SelStartSelLength( RedoSelStart, -RedoSelStart )
		Ed.SelText = Ed.SelText+Ls.item(redoPosition)
	case else:
		SelStartSelLength( RedoSelStart, 1 )
		Ed.SelText = Ls.item(redoPosition)+Ed.SelText
	end select
'	SelCorrectPosition_Simple
	Inc_undoPosition:	showUndoPosition
elseif (LenRedo > 1) then
	SELECT CASE ItemType$
	CASE "B": 'VK_BACK
			Ed.SelStart = RedoSelStart
			Ed.SelLength = -Len(Ls.item(redoPosition))+1
			Ed.SelText = ""
			Inc_undoPosition:	showUndoPosition
	CASE "R": 'VK_RETURN
			SelStartSelLength( RedoSelStart, 0 ) ' developing
			Ed.SelText = NEWLINE$
			Inc_undoPosition:	showUndoPosition
	CASE "D": 'VK_DELETE
			SelStartSelLength( RedoSelStart, Len(Ls.item(redoPosition))-1)
			Ed.SelText = ""
			Inc_undoPosition:	showUndoPosition
	CASE "P": 'PASTE_KEY
			SelStartSelLength( RedoSelStart, 0 )
			Ed.SelText = left$(Ls.item(redoPosition),Len(Ls.item(redoPosition))-1)
'			SelCorrectPosition
'			Ed.SelStart = RedoSelStart
			Inc_undoPosition:	showUndoPosition
	END SELECT
end if
DownKey = NONE_KEY '// protect onchange event
end sub

sub iDelWordCk
	if (Ed.SelStart <> Len(Ed.Text)) then '// not add UndoList if SelStart at last position
		DelWord
		Ed.SelLength = Rspace
		Ed.SelText = ""
	end if
end sub

sub iBackWordCk
		if (Ed.selLength <> 0) then ' Del by hilights
			DelBackHilight
			Ed.SelText = "" ' delete
		else ' (Ed.SelLength = 0) ' Del by not hilights
			if (Ed.SelStart <> 0) then
				DelBack
				Ed.SelLength = -Lspace
				Ed.SelText = "" ' delete
			end if
		end if
end sub

sub iEditCk
iUndo.Enabled = Not (undoPosition = -1)
iRedo.Enabled = (undoPosition < LsN.itemCount - 1)
'iDelWord.Enabled = (Ed.SelStart < Len(Ed.Text))
'iBackWord.Enabled = (Ed.SelStart > 0)
iCut.Enabled = (Ed.SelLength > 0)
iCopy.Enabled = iCut.Enabled
'v@lue31999 is max value of Len(Clipboard.Text) on my pc, Windows98se
iPaste.Enabled = Not ((Len(Clipboard.Text) = 0) or (Len(Clipboard.Text) = 31999))
iSelAll.Enabled = (Len(Ed.Text) > 0)
end sub

sub iCutCk
	DelBackHilight
	Ed.CutToClipboard
end sub

sub iCopyCk
	Ed.CopyToClipboard
end sub

sub iPasteCk
	DownKey = PASTE_KEY
	selBegin = Ed.SelStart
	TextCount = Len(Ed.Text)
	Ed.PasteFromClipboard
end sub

sub iSelAllCk
	Ed.SelectAll
end sub

' // PROPERTIES //
Mn.parent = form
Mn.Additems iEdit, iHelp

iHelp.caption = "&help"
iHelp.Additems iAbout
iAbout.caption = "&about"
iAbout.onclick = aboutShow

iEdit.caption = "&Edit"
iEdit.Additems iUndo, iRedo, iDelWord, iBackWord, iCut, iCopy, iPaste, iSelAll, iEditMode
iEdit.onclick = iEditCk
iUndo.caption = "&Undo"
iUndo.shortcut = "Ctrl+Z"
iUndo.onclick = iUndoCk
iRedo.caption = "&Redo"
iRedo.shortcut = "Ctrl+Y"
iRedo.onclick = iRedoCk
iDelWord.caption = "Del &Word"
iDelWord.shortcut = "Ctrl+Del"
iDelWord.onclick = iDelWordCk
iBackWord.caption = "Del Word &Back"
iBackWord.shortcut = "Ctrl+BkSp"
iBackWord.onclick = iBackWordCk
iCut.caption = "Cu&t"
iCut.shortcut = "Ctrl+X"
iCut.onclick = iCutCk
iCopy.caption = "&Copy"
iCopy.shortcut = "Ctrl+C"
iCopy.onclick = iCopyCk
iPaste.caption = "&Paste"
iPaste.shortcut = "Ctrl+V"
iPaste.onclick = iPasteCk
iSelAll.caption = "Select &All"
iSelAll.shortcut = "Ctrl+A"
iSelAll.onclick = iSelAllCk
iEditMode.caption = "Edit Mode"
iEditMode.shortcut = "Ins"
iEditMode.Enabled = 0
'iEditMode.onclick = iEditModeCk

Ed.parent = form
Ed.width = 225
Ed.height = 180
Ed.wanttabs = 1
Ed.onKeydown = edkbdown
Ed.onChange = edbkbChg
'Ed.Text = "abc"

with LsVal
.parent = form
.top = 185
.width = 375
.height = 75
.text = "Debug Box"
end with

LsUndoIndex.parent = form
LsUndoIndex.Left = 230
LsUndoIndex.width = 30
LsUndoIndex.height = 180
LsUndoIndex.Columns = 1
LsUndoIndex.Clear

Ls.parent = form
Ls.Left = 265
Ls.width = 60
Ls.height = 180
Ls.Columns = 1
Ls.Clear

LsN.parent = form
LsN.Left = 325
LsN.width = 50
LsN.height = 180
LsN.Columns = 1
Ls.Clear

Form.width = 390
Form.height = 310
Form.Caption = "UNDO/REDO BOX VERSION 1.0a"
Form.ShowModal