Code: Select all
tokens:
1 - B
2 - space
3 - M
4 - 100
5 - ,
6 - 100
7 - space
8 - R
9 - 5
10 - .
11 - 5
12 - space
13 - U
14 - 3Code: Select all
type lexer
'' public interface for the class
public:
declare constructor( byref inpString as const string, byref del as const string )
declare function getToken() as string
'' private members for maintaining state
private:
as string m_lookChar '' the current char that m_charPos points to
as string m_delimiters '' delimiters that are used for string splicing
as string m_inputString '' the string to be spliced
as uinteger m_charPos '' current char position on string
as uinteger m_stringLen '' the input string length
'' helper functions
'' if one were to override these helpers in a derived classes, they should be declared protected
declare sub getChar()
declare function isDelimiter( byref c as string ) as integer
end type
constructor lexer( byref inpString as const string, byref del as const string )
/'
the constructor for the class
note that, as it is an immutable class, it makes no sense to create a default, empty
constructor, for it needs data to perform its function. This form of passing data to
immutable objects is called 'dependency injection'
'/
m_inputString = inpString
m_stringLen = len( m_inputString )
m_charPos = 0
m_lookChar = ""
m_delimiters = del
end constructor
function lexer.getToken() as string
/'
retrieves the next token on the input string
if there are no more tokens to retrieve, it returns an empty string to signal
that there are no more tokens to splice
'/
dim as string ret
'' feed a char to the current char if it's empty
if( asc( m_lookChar ) = 0 ) then
getChar()
end if
/'
this is the only complicated piece of code of the class
it works like this:
IF the current char is a delimiter OR the char pos is beyond the string length THEN
get the next char to advance the char position to the beginning of the next token
(remember that, if there are no more chars in the string, getChar() returns an empty string)
return the delimiter
ELSE
WHILE the current character isn't a delimiter and the current character is not an empty string DO
assemble the current char into the token
get the next char
LOOP
return the assembled token
END IF
'/
if( ( isDelimiter( m_lookChar ) ) orElse ( m_charPos >= m_stringLen ) ) then
ret = m_lookChar
getChar()
return( ret )
else
do while( ( not isDelimiter( m_lookChar ) ) andAlso ( m_lookChar <> "" ) )
ret += m_lookChar
getChar()
loop
return( ret )
end if
end function
sub lexer.getChar()
'' if the char pos is still less than the input string length, read the next char
if( m_charPos < len( m_inputString ) ) then
m_lookChar = chr( m_inputString[ m_charPos ] )
m_charPos += 1
else
'' if not, this will signal the end of the string (as there are no more chars to read)
m_lookChar = ""
end if
end sub
function lexer.isDelimiter( byref c as string ) as integer
'' returns true (any value but zero) if the string c is a delimiter
return( iif( instr( m_delimiters, c ) > 0, -1, 0 ) )
end function
dim as string inputString = "B M100,100 R5.5 U3"
dim as string delimiters = "BM,RU "
dim as lexer lx = lexer( inputString, delimiters )
dim as string token = lx.getToken()
do while( token <> "" )
? token
token = lx.getToken()
loop
sleep()
Code: Select all
...
'if (not m_isDelimiter(m_lookChar)) and (m_charPos < m_stringLen) then
if m_charPos < m_stringLen then
while (not m_isDelimiter(m_lookChar)) and (m_lookChar <> "")
ret += m_lookChar
m_getChar()
wend
return ret
end ifBecause that's some old code (my defacto lexer is more complicated, a little overkill for this simple task). That should read:Munair wrote:In the lexer, why do you double test "not m_isDelimiter" in the function GetToken. It generates two extra expensive function calls:
Code: Select all
do while( not m_isDelimiter( m_lookChar ) and m_lookChar <> "" )
ret &= m_lookChar
m_getChar()
loop
return( ret )
You're welcome. I updated the code, so now it's shorter and cleaner, as it was coded aeons ago and unmaintained (I only added those comments for another user, owen).sancho3 wrote:Excellent example. Thanks.
I never thought to split via delimiters. Instead I was reading each character.
Code: Select all
#include "crt.bi" 'for puts
sub tokens(s as string, d as string,g() as string)
redim g(0)
dim as string tmp,char
dim as long finish=len(s)-1
#define update(z) redim preserve g(1 to ubound(g)+1):g(ubound(g))=z:tmp=""
for n as long=0 to finish
char=chr(s[n])
tmp+=char
if instr(d,char) or n=finish then
if len(tmp)>1 then
update(rtrim(tmp,char))
update(char)
else
update(tmp)
end if
end if
next
end sub
Dim As String s= "B M100,100 R5.5 U3"
Dim As String delim = "BM,RU "
redim as string results()
tokens(s,delim,results())
for n as long=lbound(results) to ubound(results)
print results(n)
next
print "Press a key"
sleep
'========== EXAMPLE 2 =======
function Ellipse(x as single,y as long,rx as long,ry as long,angle as long,col as ulong,paintflag as integer=1) as string
dim as string s="Ta" &angle &"Bm" &x &"," &y:s+="Bm+" &rx &"," &0:s+="C" &col
dim as single pi2=8*atn(1)
dim as integer lx,ly
for z as single=0 to pi2*1.1 step pi2/60 '60 steps
if z>pi2 then exit for
dim as integer xpos=rx*cos(z)
dim as integer ypos=ry*sin(z)
if z<>0 then s+="M+" &(xpos-lx) &"," &(ypos-ly)
lx=xpos:ly=ypos
next z
if paintflag then s+="BM" &x &"," &y &"P" &col &"," &col
return s
end function
screen 19
dim as string e=ellipse(400,300,200,100,45,4,1)
E=ucase(e)
draw E
color 15
print E
puts " "
puts " "
redim as string tkns()
tokens(e,"TBMA+,P",tkns())
for n as long=lbound(tkns) to ubound(tkns)
puts tkns(n)
next
sleep
I simply replaced it with my own DRAW commands. That way it is readable rather than a cryptic shorthand language and you can add things like pen size and give it float values for rotation.sancho3 wrote:The draw command is an hateful thing to work with (imho). I can only see very limited usefulness in it.
Code: Select all
dim as string bitmap= "horse.bmp_"'if bitmap is valid it will load
dim as integer bitmapFlag
dim as string d
Dim Shared As Integer xres,yres
#define shaped 16
#define alphablend 64
#define OnTop 32
#define GetWindowHandle 2
Screeninfo xres,yres
'xres=800
'yres=600
Screenres int(.9*xres),int(.9*yres),32,,SHAPED Or ALPHABLEND Or ONTOP
Type v2
As Integer x,y
col As Ulong
as ushort Bits
End Type
Function Size(bmp As String) As V2 'get bitmap width/height/ colour resolution
dim as V2 b
Open bmp For Binary access read As #1
Get #1, 19, b.X
Get #1, 23, b.Y
get #1, 29, b.Bits
Close #1
Return b
End Function
declare function FileLen alias "fb_FileLen" ( byval filename as zstring ptr ) as longint
declare function FileExists alias "fb_FileExists" ( byval filename as zstring ptr ) as integer
dim as any ptr bitmapim
if FileExists(bitmap) then
bitmapflag=1
var sz=size(bitmap)
bitmapim=imagecreate(sz.x,sz.y)
bload bitmap,bitmapim
end if
Dim Shared As Integer monitorX,monitorY
Dim Shared As Integer WinposX,WinposY
Screeninfo monitorX,monitorY
'set up for opaque screen
Extern "windows" Lib "user32"
Declare Function GetDC Alias "GetDC" (Byval As Any Ptr) As Any Ptr
End Extern
Extern "windows" Lib "gdi32"
Declare Function _point Alias "GetPixel"(Byval As Any Ptr,Byval As Integer,Byval As Integer) As Ulong
End Extern
Declare Function SLWA Alias "SetLayeredWindowAttributes" (Byval As Any Ptr, Byval As Uinteger, Byval As Ubyte, Byval As Integer) As Integer
Declare Function NoConsole Alias "FreeConsole" As Integer
Declare Function _getmouse Alias "GetCursorPos" (Byval As Any Pointer) As Integer
declare function showconsole alias "AllocConsole"() as integer
Sub BlendWindow( Byval Alpha_Value As Ubyte )
Dim Win As Any Ptr
var Ip = Cptr(Integer Ptr,@Win )
Screencontrol GETWINDOWHANDLE, *Ip
SLWA Win,Rgba(255,0,255,0),Alpha_Value,2 Or 1
End Sub
'---------------------------------------
Type Point
As Single x,y,r
As Integer counter
As Ulong col
End Type
Type screenpoint
As long x,y
End Type
Sub getmoose(Byref mx As Integer,Byref my As Integer,byref mb as integer=0,byref mw as integer=0)
getmouse mx,my,mw,mb
#define _map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
ScreenControl 0, WinposX,WinposY
Dim As screenpoint mouse=Type<screenpoint>(mx,my)
_getmouse(@mouse)
mx=_map(0,MonitorX,mouse.x-WinposX,0,MonitorX)
my=_map(0,monitorY,mouse.y-WinposY,0,MonitorY)
End Sub
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define inpoint(c,mx,my) (mx)>(c.x-c.r) And (mx)<(c.x+c.r) And (my)>(c.y-c.r) And (my)<(c.y+c.r)
#define Red(col) cptr(ubyte ptr,@col)[2]
#define Green(col) cptr(ubyte ptr,@col)[1]
#define Blue(col) cptr(ubyte ptr,@col)[0]
dim shared as integer sx=50,sy=50 'screen start position
Sub moveall
Dim As Integer mx,my,mb,x,y,dx,dy
Static As Integer lastmx,lastmy
Getmouse mx,my,,mb
Screencontrol 0, x, y
Static As Integer pressed,moved
If mb=1 Then pressed=-1 else pressed=0
If lastmx<>mx Or lastmy<>my Then moved=-1 Else moved=0
If moved Then dx=lastmx-mx:dy=lastmy-my
If pressed And moved Then
Screencontrol 100, x-dx, y - dy
sx=x-dx:sy=y-dy
pressed=0
Exit Sub
End If
lastmx=mx:lastmy=my
End Sub
sub traceover(a() as point, col as ulong,l as integer,im as any ptr=0)
for n as integer=l to ubound(a)-1
line im,(a(n).x,a(n).y)-(a(n+1).x,a(n+1).y),col
next n
end sub
Dim As Point c(1 To 5) 'the four boxes on top
Redim As Point Ccolours(0) 'the coloured boxes below
Redim As Point s(0) 'the array running parallel(Legacy from an older program, but still handy)
Dim As Point slide(1 To 3) 'the colour slider circles
Dim As Any Pointer im=imagecreate(.9*xres,.9*yres,Rgb(0,0,0))
Screeninfo xres,yres
Dim As Any Ptr MyScreen = GetDC(0)
'slider ball circles
slide(1).y=.92*yres:slide(1).r=5:slide(1).col=Rgb(200,0,0)
slide(2).y=.94*yres:slide(2).r=5:slide(2).col=Rgb(0,200,0)
slide(3).y=.96*yres:slide(3).r=5:slide(3).col=Rgb(0,0,200)
'the three larger circles
c(1).x=.3*xres:c(1).y=20:c(1).r=10
c(2).x=.5*xres:c(2).y=20:c(2).r=10
c(3).x=.9*xres:c(3).y=20:c(3).r=10
c(4).x=.7*xres:c(4).y=20:c(4).r=10
c(5).x=.1*xres:c(5).y=25:c(5).r=10
'========= DRAW STUFF TO AN IMAGE ================
'The colour boxes
dim as string border=Str(Rgb(0,200,0))',lastborder,starter
Line im,(0,0)-(xres,50),Rgb(100,100,255),bf
Dim As Integer ypos=.9*yres
Dim As Integer _st=.4*xres/25
Dim As Ulong col,tally,total,delta1
Line im,(0,.9*yres)-(xres,yres),Rgb(100,100,255),bf
Line im,(.6*xres,.92*yres)-(.75*xres,.92*yres),Rgb(200,0,0)
Line im,(.6*xres,.94*yres)-(.75*xres,.94*yres),Rgb(0,200,0)
Line im,(.6*xres,.96*yres)-(.75*xres,.96*yres),Rgb(0,0,200)
For y As Integer=_st To 4*_st Step _st
tally+=1
For x As Integer=.1*xres To .5*xres Step _st
total+=1
delta1=map((.1*xres),(.5*xres),x,0,254)
Select Case tally
Case 1: col=Rgb(255,delta1,0)
Case 2:col=Rgb(0,255,delta1)
Case 3:col=Rgb(delta1,0,255)
Case 4:col=Rgb(255-delta1,255-delta1,255-delta1)
End Select
Redim Preserve Ccolours(1 To total)
Ccolours(total)=Type<Point>(x,ypos+y-_st,_st,0,col)
Line im,(x-_st/2,ypos-_st/2+y)- (x+_st/2,ypos+_st/2+y),col,bf
Line im,(x-_st/2,ypos-_st/2+y)- (x+_st/2,ypos+_st/2+y),rgb(0,0,0),b
Next x
Next y
'================= GRID AND CIRCLES =======================
For x As Integer=0 To xres Step 50
Line im,(x,50)-(x,yres),Rgba(255,255,255,200)'50 before
Next x
For y As Integer=50 To yres Step 50
Line im,(0,y)-(xres,y),Rgba(255,255,255,200)
Next y
For z As Integer=1 To 4
line im,(c(z).x-c(z).r,c(z).y-c(z).r)-(c(z).x+c(z).r,c(z).y+c(z).r),Rgb(255,255,255),b
'Circle im,(c(z).x,c(z).y),c(z).r+1,Rgb(255,255,255)
Next z
if bitmapflag=1 then line im,(c(5).x-c(5).r,c(5).y-c(5).r)-(c(5).x+c(5).r,c(5).y+c(5).r),Rgb(255,255,255),b
Line im,(0,.9*yres)-(xres,.9*yres),Rgb(0,200,0)
Draw String im,(c(1).x-150,c(1).y),"NEW POINTS -->"
Draw String im,(c(2).x-80,c(2).y),"FILL -->"
Draw String im,(5,5), "SCREEN RESOLOTIONS = " &xres-1 &"," &yres-1
Draw String im,(.9*xres-50,35),"SCREEN TOGGLE"
Draw String im,(.7*xres-70,35),"SEE THROUGH TOGGLE"
if bitmapflag=1 then
Draw String im,(.1*xres-70,40),"BITMAP TOGGLE"
end if
'================ IMAGE NOW DRAWN =========================
Noconsole 'hide the dos box
'===============================================
'some variables
Dim As Integer mx,my,mb,flag1,flag2,flag3,flag4,flag5,flag6,flag7,toggle=1,counter,paintflag,contrast=1
dim as integer flag8,bitmaptoggle=1
Dim As Integer dx,dy
Dim As String key
Dim As String fill=Str(Rgb(255,255,255))
dim as string delta,first
d="""C"+border+"B" +d
Dim As String f=d
Dim As Integer count,cm,z
Dim As Integer rd,gr,bl,lower=1
Dim As Ulong boxcol=valulng(fill),circ1col,circ2col
dim as integer bitmapx=0,bitmapy=50,bflagx,bflagy
counter=0
'======================== SHOW THE SCREEN =================
#macro showscreen()
Screenlock
Cls
Put(0,0),im,alpha
if bitmaptoggle=1 then
if bitmapflag then put(bitmapx,bitmapy),bitmapim,pset
end if
'highlight the newpoints box
line(c(1).x+c(1).r-1,c(1).y+c(1).r-1)-(c(1).x-c(1).r+1,c(1).y-c(1).r+1),circ1col,bf
'draw the colour slider circles
For z As Integer=1 To 3
Circle(slide(z).x,slide(z).y),slide(z).r,slide(z).col,,,,f
Next z
'highlight the fill circle
Circle(c(2).x,c(2).y),c(2).r-1,circ2col,,,,f
circle(c(3).x,c(3).y),c(3).r-1,circ2col
'the coloured square
Line(.8*xres,.9*yres)-(.85*xres,.95*yres),boxcol,bf
'top and base of drawing area
Line (0,.9*yres)-(xres,.9*yres),valuint(border)
line (0,50)-(xres,50),valuint(border)
Draw String(xres/3,60),"mouse " & mx &" " & my
Draw String(xres/2,60),"Previous mouse " &s(Ubound(s)).x & " " &s(Ubound(s)).y
'the rbg values of the fill colour shown
Draw String(.8*xres,.975*yres),"RGB(" &RED(boxcol) &"," &GREEN(boxcol) &"," & BLUE(boxcol) &")",Rgb(255,255,255)
Draw d 'MAIN STRING
traceover(s(),boxcol,lower)
'small spot at mouse
pset (s(Ubound(s)).x,s(Ubound(s)).y)
if contrast=1 then line(0,50)-(xres,.9*yres),rgba(0,0,0,150),bf
Screenunlock
Sleep 1,1
#endmacro
'=============================================================
Do
getmoose(mx,my,mb)
key=Inkey
cm=0
'Set the slider bobs to match the fill colour (boxcol)
slide(1).x=map(0,255,RED(boxcol),(.6*xres),(.75*xres))
slide(2).x=map(0,255,GREEN(boxcol),(.6*xres),(.75*xres))
slide(3).x=map(0,255,BLUE(boxcol),(.6*xres),(.75*xres))
'colours highlight at mouse inside(Two boxes at the top, not the toggle)
circ1col=Rgb(100,100,255)
circ2col=Rgb(100,100,255)
'arrow keys to shift the screen
if bflagx=0 and bflagy=0 then
If key=Chr(255)+"K" Then sx-=5:bflagx=1
If key=Chr(255)+"M" Then sx+=5:bflagx=1
If key=Chr(255)+"P" Then sy+=5:bflagy=1
If key=Chr(255)+"H" Then sy-=5:bflagy=1
end if
if len(key)=0 then bflagx=0:bflagy=0
if bitmapflag=0 then
screencontrol 100,sx,sy
'bflag=0
else
if bflagx then bitmapx+=sgn(sx-50)*5:sx=50
if bflagy then bitmapy+=sgn(sy-50)*5:sy=50
end if
'CHECK THE MOUSE IN:
If mb=1 And flag6=0 Then 'the colours in the boxes at the bottom
flag6=1
For z =1 To Ubound(Ccolours)
If inpoint(Ccolours(z),mx,my+5)=0 Then boxcol=Ccolours(z).col':border=str(boxcol)
Next z
End If
flag6=mb
For cm=Lbound(c) To Ubound(c) 'Check for mouse in a box (upper screen)
If inpoint(c(cm),mx,my) Then Exit For
If my>.9*yres Then cm=-1: Exit For
Next cm
If cm=5 and bitmapflag=1 Then 'BITMAP TOGGLE
If mb=1 And flag8=0 Then
flag8=1
bitmaptoggle=-bitmaptoggle
End If
End If
flag8=mb
If cm=4 Then 'CONTRAST TOGGLE
If mb=1 And flag7=0 Then
flag7=1
contrast=-contrast
End If
End If
flag7=mb
If cm=3 Then 'SCREEN TOGGLE
If mb=1 And flag5=0 Then
flag5=1
toggle=-toggle
If toggle=-1 Then blendwindow(100) Else blendwindow(255)
End If
End If
flag5=mb
If cm=2 And Ubound(s)>=3 Then 'FILLER
If PaintFlag Then circ2col=boxcol
If mb=1 And flag4=0 Then
flag4=1
fill= Str(boxcol)
'var t=ltrim(starter ,"""C")
If PaintFlag Then d+="P"+fill+","+border't'str(boxcol)'border
End If
End If
flag4=mb
If cm=1 Then 'NEW START
circ1col=Rgb(0,200,0)
If mb=1 And flag3=0 Then
flag3=1
lower=ubound(s)+1
d+=""""+"_"+Chr(10)+"&"+""""
d+="B"
End If
End If
flag3=mb
If my<50 And cm=Ubound(c)+1 then moveall:cm=0 'if mouse in top frame
'CREATE THE STRING FOR DRAW.
'AND CREATE AN ARRAY IN PARALLEL
If mb=1 And flag1=0 And cm=Ubound(c)+1 Then
flag1=1:counter+=1
Redim Preserve s(1 To Ubound(s)+1)
s(Ubound(s))=Type<Point>(mx,my,0,counter)
Dim As Integer dx,dy
If counter=1 Then dx=mx:dy=my Else dx=mx-s(Ubound(s)-1).x:dy=my-s(Ubound(s)-1).y
If counter=1 Then d+="M"+Str(dx)+","+Str(dy) Else d+="M+"+Str(dx)+","+Str(dy)
count+=1
If count>5 Then d+=""""+"_"+Chr(10)+"&"+"""":count=0
End If
flag1=mb
'go back on right mouse click(delete mistakes)
If mb=2 And flag2=0 Then
flag2=1
If counter>1 Then Redim Preserve s(1 To Ubound(s)-1):counter-=1
If counter=1 Then Redim s(0):counter=0
delta=Mid(d,instrrev(d,"M"))
d=Rtrim(d,delta)
End If
flag2=mb
showscreen()
'the colour sliders
For z As Integer=1 To 3 'in the colour sliders
If inpoint(slide(z),mx,my) Then
While mb = 1
Getmouse mx,my,,mb
showscreen()
If mx<>slide(z).x Or my<>slide(z).y Then
rd=RED(boxcol):gr=GREEN(boxcol):bl=BLUE(boxcol)
slide(z).x=mx
If slide(z).x<.6*xres Then slide(z).x=.6*xres
If slide(z).x>.75*xres Then slide(z).x=.75*xres
Select Case As Const z
Case 1: rd=map((.6*xres),(.75*xres),slide(1).x,0,255)
Case 2: gr=map((.6*xres),(.75*xres),slide(2).x,0,255)
Case 3: bl=map((.6*xres),(.75*xres),slide(3).x,0,255)
End Select
If rd<0 Then rd=0:If rd>255 Then rd=255
If gr<0 Then gr=0:If gr>255 Then gr=255
If bl<0 Then bl=0:If bl>255 Then bl=255
boxcol=Rgb(rd,gr,bl)
End If
Wend
End If
Next z
If Len(d)-Instrrev(d,"B")<18 Then PaintFlag=1 Else PaintFlag=0
Loop Until key =Chr(27)
d+=""""
screeninfo xres,yres
dim as any ptr lastscreen=imagecreate(xres,yres,0)
get(0,0)-(xres-1,yres-1),lastscreen
dim as string q
screenres xres,yres,32
put(0,0),lastscreen,pset
draw string(100,100),"Do you wish to save -- y/n",rgb(255,255,255)
var ff=freefile
do
q=input(1)
loop until lcase(q)="n" or lcase(q)="y"
if lcase(q)="n" then goto fin
locate 6,6
if Open ("DRAWINGpoints.bas" For Output As #ff)=0 then print "saved":beep else print "Fail"
Print #ff,"Dim as string zz = _"
Print #ff,d
Print #ff,"'Number off points ";Ubound(s)
Print #ff,"Screenres ";xres;",";yres;",";32
Print #ff, "Draw zz"
Print #ff,"Sleep"
Close #ff
shell "notepad DRAWINGpoints.bas"
Sleep
fin:
imagedestroy im
imagedestroy lastscreen
if bitmapim<>0 then imagedestroy bitmapim
Code: Select all
#Include "file.bi"
Sub savefile(filename As String,p As String)
Dim As Integer n
n=Freefile
If Open (filename For Binary Access Write As #n)=0 Then
Put #n,,p
Close
Else
Print "Unable to save " + filename
End If
End Sub
Function loadfile(file as string) as String
If FileExists(file)=0 Then Print file;" not found":Sleep:end
var f=freefile
Open file For Binary Access Read As #f
Dim As String text
If Lof(1) > 0 Then
text = String(Lof(f), 0)
Get #f, , text
End If
Close #f
return text
end Function
Function FindAndReplace(byval s As String,Find As String,Replace As String) byref As const String
static As long position
position=Instr(s,Find)
While position>0
s=Mid(s,1,position-1) & Replace & Mid(s,position+Len(Find))
position=Instr(position+Len(Replace),s,Find)
Wend
return s
End Function
dim as string s
s=!"Dim as string s\n"
s+= "s=""Hello" _ bla bla bla
!" World!""\n"
s+=!"sleep\n"
print s
savefile("silly.txt",s)
dim as string g=loadfile("silly.txt")
print g
var h= FindAndReplace(g,chr(10),":")
print h
print h
kill "silly.txt"
sleep
Code: Select all
dim as string s
s=!"Dim as string _\n"
s &= !"s\n"
s+= "s=""Hello" _ bla bla bla
!" World!""\n"
s+=!"sleep\n"
print s