the parabolic mirror designer
can help you with parabolic shapes (in case you did not knew how to build them)
have fun ... :)
[i feel smoke, don't you ? c*** ! my house's on fire :)) ]
file [parabolic.bas]
Code: Select all
'sdsmst signature = file parabo.bas
'programmed by zdupy (aka mihai barboi, ro, eu)
'copyright (c), 1996-2011, alphax (r) team
'this program will help you create 3d parabolic mirrors;
'it can provide you detailed sizes and lengths about your mirror
'during [3D view] press [F1] to get help about keys (rotation, movement, etc ...)
#Include "easy.bas"
#Include "fbgfx.bi"
Using fb
Type pairs
As Double x,y,x2,y2
End Type
#Define pi 3.1415926535897932384626433832795
#Define c180pi 57.2957795130823208767981548141052
#Ifndef cpi180
#Define cpi180 0.0174532925199432957692369076848861
#EndIf
#Define log10 2.30258509299404568401799145468436
#Define log10inv 0.434294481903251827651128918916605
#Define to_degree2(xxxx) ((xxxx*c180pi) Mod 360)
#Define to_degree(xxxx) (xxxx*c180pi)
#Ifndef to_rads
#Define to_rads(xxxx) (xxxx*cpi180)
#EndIf
#Define logit(xxxx) CInt((xxxx*10^abs((Log(rref)*log10inv))))
Sub parabolic()
'part of my [jonction2.bas]
Dim As Double focal=0.5
Dim As Double seg_len=0.02
Dim As Integer maxs=25
Dim As Double scale_x,scale_y
Dim As Integer i,k,j
Dim As pairs Ptr segs
Dim As Double jx,jy,ca,sa,rx,ry
Dim As Integer mx,my,maxx3,maxy3
Dim As Double alpha1,beta1,gamma1,fx,fy,dx,dy,ffy,sl,incr,rref
Dim As Integer detailed=1
Dim As ZString*256 sel
restart111:
win 10,10,maxcol-10,16," Parabolic mirror ",yellow1,bluelow1
CenterC 11,"The program will generate a 3D view of the mirror you need."
CenterC 12,"It will also display sizes and lengths for construction purposes."
CenterC 13,"But first you need to feed the program with some parameters."
Color white1
CenterC 14,"Next you'll be asked about: [focal point],[mirror segment len] & [num segments]"
Color black1
CenterC 15,"[press any key]"
pause1
Color white1,black1
cls
ScreenInfo mx,my
maxx3=mx:maxy3=my
mx Shr=1
my Shr=1
Color RGB(230,230,230),RGB(100,10,240)
Print "This algorithm will display/compute sizes for a parabolic mirror."
Color RGB(130,130,130),RGB(0,0,0):Print "focal point (R)meters:";
Color RGB(250,250,10),RGB(10,130,24):focal=Val(get_smart(Str(focal),Pos(0),CsrLin)):Print
Color RGB(130,130,130),RGB(0,0,0):Print "segment length (L)meters:";
Color RGB(250,250,10),RGB(10,130,24):seg_len=Val(get_smart(Str(seg_len),Pos(0),CsrLin)):Print
Color RGB(130,130,130),RGB(0,0,0):Print "max. num of segments per side:";
Color RGB(250,250,10),RGB(10,130,24):maxs=ValInt(get_smart(Str(maxs),Pos(0),CsrLin)):Print
If (maxs*2*Len(pairs)) >Fre Then
Color RGB(130,130,130),RGB(0,0,0):Print "Not enogh memory ! Too many segments !"
Print "max segments=";Fre/(Len(pairs)*2)
pause1
GoTo restart111
EndIf
Color white1,black1
Print "Detailed analysis ?";
get_likecombo "[yes :1][no :0]",@sel,@detailed,Pos(0),CsrLin,yellow1,blue1
Color white1,black1:print
If maxs=0 Then End
'---------------------------------------------------------------------------
' this is the hearth of the algorithm : the geometry part
'[start]
scale_x=(mx*1.8)*25*(0.02/seg_len)/IIf(maxs>25,CInt(maxs),25)
scale_y=(my*1.8)*25*(0.02/seg_len)/IIf(maxs>25,maxs,25)
If segs<>0 Then DeAllocate segs
segs=Callocate(Len(pairs)*(maxs+2)*2)
i=maxs
segs[i].x=-seg_len/2
segs[i].y=focal
segs[i].x2=seg_len/2
segs[i].y2=focal
dx=((maxs/(100*(0.02/seg_len)))/focal)*(seg_len)/(maxs)
dy=dx
sl=seg_len
i+=1
'right side (positive x)
While i<=(maxs Shl 1)
With segs[i]
.x=segs[i-1].x2
.y=segs[i-1].y2
.x2=.x+seg_len
.y2=.y-dy
'Print .x;.y;.x2;.y2
sl+=Sqr(seg_len*seg_len+dy*dy)
dy+=dx
End With
i+=1
Wend
'GoTo nex
i=maxs
i-=1
dy=dx
'left side (negative x)
While i>=0
With segs[i]
.x2=segs[i+1].x
.y2=segs[i+1].y
.x=.x2-seg_len
.y=.y2-dy
sl+=Sqr(seg_len*seg_len+dy*dy)
'Print .x;.y;.x2;.y2
dy+=dx
End with
i-=1
Wend
'[/stop]
'pause1
'2d analysis part
nex:
cls
Line (mx-1,my-1)-(mx+1,my+1),blue1,bf
If detailed=0 Then
For i=0 To (maxs Shl 1)
With segs[i]
Line (mx+.x*scale_x,my+.y*scale_y)-(mx+.x2*scale_x,my+.y2*scale_y),red1
jx=(.x+.x2)/2
jy=(.y+.y2)/2
Line (mx+jx*scale_x,my+jy*scale_y)-(mx+jx*scale_x,0),yellowmid1
End With
If MultiKey(SC_ESCAPE)<>0 Then Exit For
Next i
End If
For i=0 To (maxs Shl 1)
With segs[i]
If detailed=1 then Line (mx+.x*scale_x,my+.y*scale_y)-(mx+.x2*scale_x,my+.y2*scale_y),red1
jx=(.x+.x2)/2
jy=(.y+.y2)/2
If detailed=1 Then Line (mx+jx*scale_x,my+jy*scale_y)-(mx+jx*scale_x,0),yellowmid1
gamma1=Atan2(.y-.y2,.x-.x2)
alpha1=(pi/2)-gamma1
beta1=alpha1-gamma1
fx=0
fy=(Tan(beta1))*((.x+.x2)/2)+((.y+.y2)/2)
If i=(maxs Shr 1) Then ffy=fy
Line (mx+jx*scale_x,my+jy*scale_y)-(mx+fx*scale_x,my+fy*scale_y),white1
If detailed=1 Then
Locate 1,1
Print "[angle(sun ray,segnent)="; CSng(to_degree2(alpha1));"] "
Print "[angle(reflected,X axis)=";CSng(to_degree2(beta1));"] "
Print "[angle(segment,X axis)=";CSng(to_degree2(gamma1));" ] "
Print "[aberation=";CSng(focal-((.y+.y2)/2));"] "
Print "[displacement=";CSng((.x+.x2)/2);"] "
pause1 "<press any key to advance ...>"
End If
'AO) (.x,.y)-(jx,jy)
'OB) (jx,jy)-(jx,-inf)
'0C) (jx,jy)-(rx,ry)
'<AOB=<BOC
'=======
'(rx,ry)=?
End With
If MultiKey(SC_ESCAPE)<>0 Then Exit For
Next i
Color blue1
Draw String(0,23 Shl 4),"focal point="+Str(CSng(focal-ffy))
Draw String(0,24 Shl 4),"aberation="+Str(CSng(segs[0].y-segs[maxs].y))
Draw String(0,25 Shl 4),"mirror length="+Str(CSng(sl))
Draw String(0,26 Shl 4),"light coverage="+Str(CSng(segs[maxs Shl 1].x2-segs[0].x))
Draw String(0,27 Shl 4),"effectivness="+Str(CSng((segs[maxs Shl 1].x2-segs[0].x)/sl)*100)+"%"
Draw String(0,28 Shl 4),"light power increase per meter @ focal point:"+Str(CSng((segs[maxs Shl 1].x2-segs[0].x)/seg_len)),green1
If detailed=1 Then
Draw String (0,29 Shl 4),"NOTE : angles do not reflect the right cadrant !",red1
End If
Color white1
pause1
quest1111:
Color white1,black1
win 20,14,maxcol-20,16," Parabolic mirror algorithm ",red1,greenlo1
Locate 15,21:Print "What's next ?";
get_likecombo "[3D view :2][restart :0][quit algohorithm :1]",@sel,@i,Pos(0),CsrLin,yellow1,blue1
Color white1,black1
If i=0 Then GoTo restart111
If i=2 Then
'--3d rendering part--
Dim As Double sinunghi,cosunghi,sinunghi2,cosunghi2,unghi,unghi2,xi,yi,zi,xi2,yi2,zi2,ri,ri2,u1,mu1,mu2
Dim As Double ste1,ste2
Dim As UInteger tcolo=red1,jj
Dim As Integer xx,yy,xx2,yy2,flipy,numx,uu1,numxx,wx,wy,zopt1,zopt2,mxs,mys
Dim As Double cosi(360),sini(360)
Dim As String aa
rref=seg_len/10
unghi=-392
unghi2=-403
flipy=1
sinunghi=Sin(to_rads(90-unghi))
cosunghi=cos(to_rads(90-unghi))
sinunghi2=sin(to_rads(90-unghi2))
cosunghi2=cos(to_rads(90-unghi2))
mu1=cosunghi*cosunghi2
mu2=sinunghi*cosunghi2
mxs=mx+wx
mys=my+wy
ste1=2*pi
numx=1
numxx=360
ste2=pi/(2*(numxx/4))
For i=0 To 360
cosi(i)=Cos(to_rads(i))
sini(i)=Sin(to_rads(i))
Next i
Win 10,10,maxcol-10,22," 3D View of the mirror ",yellow1,bluelow1
CenterC 11,"Based on your inputs the program will now generate the 3D preview"
Color red1
CenterC 12,"Keys"
Color white1
CenterC 13,"[1],[2] : rotate on xy axis"
CenterC 14,"[3],[4] : rotate on yz axis"
CenterC 15,"[+] or [=], [-] or [_] : zoom in/out"
CenterC 16,"[/],[*] : reduce/increase complexity"
CenterC 17,"[r] : reset view settings"
CenterC 18,"[left],[right],[up]&[down] : move mirror"
CenterC 19,"[esc] : quit algorithm and return to main menu"
CenterC 20,"[enter] : quit only 3D preview"
Color black1
CenterC 21,"[press any key]"
pause1
Color white1,black1
Cls
Do
If flipy=1 Then cls
ScreenLock
i=0
While i<=maxs
'For i=0 To (maxs)' Shl 1)
With segs[i]
Yi=.y
ri=.x
'u1=0
'While u1<ste1
'xi=.x*Cos(u1)
'zi=.x*Sin(u1)
zopt1=logit(yi)*cosunghi+mxs
zopt2=-logit(yi)*mu2+mys
uu1=0
While uu1<numxx
xi=ri*cosi(uu1)
Zi=ri*sini(uu1)
xx=-logit(xi)*Sinunghi+zopt1
yy=-logit(xi)*mu1+logit(zi)*sinunghi2+zopt2
PSet (xx,yy),tcolo
uu1+=numx
Wend
'u1+=ste2
'Wend
End With
i+=1
wend
'Next i
Draw String (0,0),"angleXY:"+Str(unghi)+" angleYZ:"+Str(unghi2)+" pix_step:"+Str(numx)+" rref:"+Str(CSng(rref)),greenlo1
Draw String (0,maxy3-16-1),"[Press <F1> for detailed help]",greenmid1
screenunlock
aa=InKey:jj=0:While aa="":jj+=1:jj=IIf(jj>=250,250,jj):Sleep jj:aa=InKey:wend
Select Case aa
Case "r","R"
unghi=0
unghi2=0
rref=seg_len/10
numx=1
wx=0
wy=0
sinunghi=Sin(to_rads(90-unghi))
cosunghi=cos(to_rads(90-unghi))
sinunghi2=sin(to_rads(90-unghi2))
cosunghi2=cos(to_rads(90-unghi2))
mu1=cosunghi*cosunghi2
mu2=sinunghi*cosunghi2
mxs=mx+wx
mys=my+wy
cls
Case Chr(255,77),Chr(0,77) 'left key
wx+=10
mxs=mx+wx
mys=my+wy
Case Chr(255,75),Chr(0,75) 'right key
wx-=10
mxs=mx+wx
mys=my+wy
Case Chr(255,72),Chr(0,72) 'up key
wy-=10
mxs=mx+wx
mys=my+wy
Case Chr(255,80),Chr(0,80) 'down key
wy+=10
mxs=mx+wx
mys=my+wy
Case Chr(255,59),Chr(0,59) 'f1
Color white1,black1
Cls
Color RGB(230,230,230),RGB(100,10,240)
center 1, "This algorithm will display/compute sizes for a parabolic mirror."
Color whitelo1,black1
center 3, "This is the 3D view of the parabolic mirror"
Color grayhi1,black1
center 5,"To rotate along the xy axis use [1] and [2]"
center 6,"To rotate along the zy axis use [3] and [4]"
center 7,"To zoom in/out use [+] and [-]"
center 8,"To adjust the number of points displayed use [/] and [*]"
center 9,"To move left/right/up/down use [LEFT],[RIGHT],[UP] and [DOWN]"
center 10,"To refresh screen use [c]"
center 11,"To switch between clearing screen after each frame and not, use [space]"
center 12,"To exit 3D view and go back to algorithm press [ENTER]"
center 13,"To exit parabolic algorithm and 3D view press [ESC]"
center 14,"To restart coordonates press [R]"
pause1
Case "p"
Locate 2,1
Print "angleXY=";unghi
Print "angleYZ=";unghi2
Print "pointsSTEP=";numxx
Print "reference_measure_unit=";rref
pause1 "[press any key]"
Cls
Case "*","8"
numx-=1
If numx<=0 Then numx=1
Case "/"
numx+=1
If numx >359 Then numx=359
Case " "
flipy=IIf(flipy=0,1,0)
Case "+","="
Cls
rref/=1.1
If rref=0 Then rref=seg_len/1.1
Case "-","_"
cls
rref*=1.1
Case "c"
cls
Case "1"
unghi-=1
sinunghi=Sin(to_rads(90-unghi))
cosunghi=cos(to_rads(90-unghi))
sinunghi2=sin(to_rads(90-unghi2))
cosunghi2=cos(to_rads(90-unghi2))
mu1=cosunghi*cosunghi2
mu2=sinunghi*cosunghi2
Case "2"
unghi+=1
sinunghi=Sin(to_rads(90-unghi))
cosunghi=cos(to_rads(90-unghi))
sinunghi2=sin(to_rads(90-unghi2))
cosunghi2=cos(to_rads(90-unghi2))
mu1=cosunghi*cosunghi2
mu2=sinunghi*cosunghi2
Case "3"
unghi2-=1
sinunghi=Sin(to_rads(90-unghi))
cosunghi=cos(to_rads(90-unghi))
sinunghi2=sin(to_rads(90-unghi2))
cosunghi2=cos(to_rads(90-unghi2))
mu1=cosunghi*cosunghi2
mu2=sinunghi*cosunghi2
Case "4"
unghi2+=1
sinunghi=Sin(to_rads(90-unghi))
cosunghi=cos(to_rads(90-unghi))
sinunghi2=sin(to_rads(90-unghi2))
cosunghi2=cos(to_rads(90-unghi2))
mu1=cosunghi*cosunghi2
mu2=sinunghi*cosunghi2
Case Chr(13)
GoTo quest1111
End Select
Loop Until aa=Chr(27)
EndIf
If segs<>0 Then DeAllocate segs
End Sub
'main module
Screen 19,32
maxcol=100
parabolic()
end
Code: Select all
'SDSMST signature for disk errors = this is file [easy.bas]
' Gnupyright (G) 1996-2011, AlphaX (R) Team
' Programmed by Mihai Barboi (aka Zdupy), Romania, Eu
'
' For license please read "The Universal Declaration of Human Rights" & GPL V2...
' Special thanls : OCW.MIT.EDU
'
declare function get_smart overload (predef as string, x as integer, y as integer) as string
declare function get_smart overload (predef as string, x as integer, y as integer, helptext as zstring ptr) as string
declare Sub get_likecombo overload (txt as string,ot1 as any ptr, info as integer ptr,x as integer, y as integer, textc as uinteger, backc as uinteger, ByRef sel As Integer=1)
declare Sub get_likecombo overload (txt as string,ot1 as any ptr, info as integer ptr,x as integer, y as integer, textc as uinteger, backc as uinteger, helptext as zstring ptr, ByRef sel As Integer=1)
declare function from_hex (a as string) as ULongInt
declare function from_hex2str (a as string) as string
Declare Function tohex1(i As ULongInt) As String
declare function get_sel(num as integer,txt as string) as string
declare function deallocate2(a as any ptr) as integer
declare function dealloc2(a as any ptr) as integer
Declare Function menu_get_opt(entries as string, x as integer, y as integer,textc as integer, backc as Integer, Byref sel As Integer=1) as String
Declare function menu_get_opt_drawonly(entries as string, x as integer, y as integer,textc as integer, backc as Integer, Byref sel As Integer=1) as string
Declare Sub dos_screenshot(Scrn As UShort Ptr, w As Integer, h As Integer)
Declare Sub dos_screenload(Scrn As UShort Ptr, w As Integer, h As Integer)
declare SUB Center (row as integer , text as string)
Declare Sub CenterNL (row as integer , text as String)
declare Sub CenterC (row as integer , text as String)
declare SUB Win (x1 as integer, y1 as integer, x2 as integer, y2 as integer, name1 as string,tc as integer, tb as integer)
declare SUB MsgBox (text as string, nume as string)
declare SUB TextXY (x as integer, y as integer, Txt as string)
declare sub print_constraint (a as string,start as integer, l as integer)
declare sub shottofile(fnm as string)
declare sub pause1 overload(a as string,x as integer)
declare sub pause1 overload(a as string)
declare sub pause1 overload(x as integer)
declare sub pause1 overload()
declare sub print_any overload (dump as ubyte)
declare sub print_any overload (dump as ubyte,sel as ushort)
Declare Sub Printnosound(brom As UByte Ptr, size As UInteger)
Declare Function hex8(i As ULongInt) As String
Declare Function hex16( As ULongInt) As String
declare Function hex24(i As ULongInt) As String
Declare Function hex32(i As ULongInt) As String
Declare Function hex64(i As ULongInt) As String
Declare Function loadbmp (fnm As String, bmpptrptr As UInteger ptr, w As Integer Ptr, h As Integer Ptr, bits As UByte Ptr,palette1 As Uinteger ptr) As Integer
Declare Sub loadbmpputcatcentertrans (ps1 As String,maxx As Integer,maxy As Integer)
Declare Sub loadbmpputcatcenter(ps1 As String,maxx As Integer,maxy As Integer)
Declare Sub rorb1(x As UByte Ptr, n As UByte)
Declare sub rolb1(x As UByte Ptr, n As UByte)
Declare Sub rorw1(x As UShort Ptr, n As UByte)
Declare sub rolw1(x As UShort Ptr, n As UByte)
Declare Sub rordw1(x As UInteger Ptr, n As UByte)
Declare sub roldw1(x As UInteger Ptr, n As UByte)
'colors
Dim Shared As UInteger black1=RGB(0,0,0)
Dim Shared As UInteger white1=RGB(255,255,255)
Dim Shared As UInteger red1=RGB(250,10,10)
Dim Shared As UInteger redmid1=RGB(128,10,10)
Dim Shared As UInteger redlo1=RGB(100,10,10)
Dim Shared As UInteger blue1=RGB(10,10,250)
Dim Shared As UInteger bluemid1=RGB(10,10,128)
Dim Shared As UInteger bluelow1=RGB(10,10,100)
Dim Shared As UInteger green1=RGB(10,250,10)
Dim Shared As UInteger greenmid1=RGB(10,128,10)
Dim Shared As UInteger greenlo1=RGB(10,100,10)
Dim Shared As UInteger yellow1=rgb(250,250,10)
Dim Shared As UInteger yellowmid1=rgb(200,200,10)
Dim Shared As UInteger graymid1=RGB(127,127,127)
Dim Shared As UInteger grayhi1=RGB(160,160,160)
Dim Shared As UInteger graylo1=RGB(100,100,100)
Dim Shared As UInteger whitelo1=RGB(200,200,200)
#Include Once "mem.bas"
'BitMap headers : extracted from wingdi.bi
#Ifndef __FIX_HEADERS__
Type BITMAPFILEHEADER field=2
bfType as UShort
bfSize as UInteger
bfReserved1 as UShort
bfReserved2 as UShort
bfOffBits as UInteger
end Type
type BITMAPINFOHEADER
biSize as UInteger
biWidth as LONG
biHeight as LONG
biPlanes as UShort
biBitCount as ushort
biCompression as UInteger
biSizeImage as UInteger
biXPelsPerMeter as LONG
biYPelsPerMeter as LONG
biClrUsed as UInteger
biClrImportant as uinteger
end Type
#EndIf
#ifdef __FB_DOS__
#Include Once "dos/dpmi.bi"
#include once "dos/sys/movedata.bi"
#EndIf
'this declaretion should sit right here !
Declare Function loadbmpheaderonly(fnm As String,bmpfh As BITMAPFILEHEADER ptr,bmpih As BITMAPINFOHEADER Ptr) As Integer
sub rolb1(x As UByte Ptr, n As UByte)
Asm
push cx
push eax
mov cl,[n]
mov eax,[x]
rol Byte Ptr [eax],cl
pop eax
pop cx
End Asm
End Sub
Sub rorb1(x As UByte Ptr, n As UByte)
Asm
push cx
push eax
mov cl,[n]
mov eax,[x]
ror Byte Ptr[eax],cl
pop eax
pop cx
End Asm
End Sub
sub rolw1(x As UShort Ptr, n As UByte)
Asm
push cx
push eax
mov cl,[n]
mov eax,[x]
rol word Ptr [eax],cl
pop eax
pop cx
End Asm
End Sub
Sub rorw1(x As UShort Ptr, n As UByte)
Asm
push cx
push eax
mov cl,[n]
mov eax,[x]
ror word Ptr[eax],cl
pop eax
pop cx
End Asm
End Sub
sub roldw1(x As UInteger Ptr, n As UByte)
Asm
push cx
push eax
mov cl,[n]
mov eax,[x]
rol dword Ptr [eax],cl
pop eax
pop cx
End Asm
End Sub
Sub rordw1(x As UInteger Ptr, n As UByte)
Asm
push cx
push eax
mov cl,[n]
mov eax,[x]
ror dword Ptr[eax],cl
pop eax
pop cx
End Asm
End Sub
Sub Print2s2cnl(txt1 As String, txt2 As String, c1 As UInteger,c2 As UInteger)
Color c1
Print txt1;
Color c2
Print txt2;
End Sub
Sub Print2s2c(txt1 As String, txt2 As String, c1 As UInteger,c2 As UInteger)
Color c1
Print txt1;
Color c2
Print txt2
End Sub
Sub Print2s2c2b(txt1 As String, txt2 As String, c1 As UInteger,c2 As UInteger,b1 As UInteger,b2 As UInteger)
Color c1,b1
Print txt1;
Color c2,b2
Print txt2
End Sub
Sub Print2s2c2bnl(txt1 As String, txt2 As String, c1 As UInteger,c2 As UInteger,b1 As UInteger,b2 As UInteger)
Color c1,b1
Print txt1;
Color c2,b2
Print txt2;
End Sub
Sub print1s1c(txt1 As String,c1 As UInteger)
Color c1
Print txt1
End Sub
Sub print1s1cnl(txt1 As String,c1 As UInteger)
Color c1:Print txt1;
End Sub
Sub print1s1cb(txt1 As String,c1 As UInteger,b1 As UInteger)
Color c1,b1:Print txt1
End Sub
Sub print1s1cbnl(txt1 As String,c1 As UInteger,b1 As UInteger)
Color c1,b1:Print txt1;
End Sub
Sub Printsn2c2b(txt1 As String, n As Double, c1 As UInteger,c2 As UInteger,b1 As UInteger,b2 As UInteger)
Color c1,b1
Print txt1;
Color c2,b2
Print n
End Sub
Sub Printsn2c2bnl(txt1 As String, n As Double, c1 As UInteger,c2 As UInteger,b1 As UInteger,b2 As UInteger)
Color c1,b1
Print txt1;
Color c2,b2
Print n;
End Sub
Sub Printsn2c(txt1 As String, n As Double, c1 As UInteger,c2 As UInteger)
Color c1
Print txt1;
Color c2
Print n
End Sub
Sub Printsn2cnl(txt1 As String, n As Double, c1 As UInteger,c2 As UInteger)
Color c1
Print txt1;
Color c2
Print n;
End Sub
'Dim Shared As UInteger easy_textcolors(256),easy_backcolors(256)
'Dim Shared As UInteger Ptr easy_txtc=@easy_textcolors(0)
'Dim Shared As UInteger Ptr easy_bacc=@easy_backcolors(0)
Function synchronize_mousekeyb As Integer
Dim As Integer mb34,mb24,mb14
While InKey<>"":Sleep 1:Wend
Do
Sleep 333
GetMouse mb14,mb24,,mb34
If InKey =Chr(27) Then Return(2)
Loop While mb34<>0
Function=1
End Function
Sub loadbmpputcatcentertrans (ps1 As String,maxx As Integer,maxy As Integer)
Dim As BITMAPFILEHEADER bmpfh
Dim As BITMAPINFOHEADER bmpih
Dim As Any Ptr pcmimg1
If loadbmpheaderonly(ps1,@bmpfh,@bmpih)=1 Then
If ((bmpih.biWidth*bmpih.biHeight*bmpih.biBitCount) Shr 3)<Fre Then
pcmimg1=ImageCreate(bmpih.biWidth,bmpih.biHeight,0)
BLoad ps1,pcmimg1
Put ((maxx Shr 1)-(bmpih.biWidth Shr 1),(maxy Shr 1)-(bmpih.biHeight Shr 1)),pcmimg1,Trans
ImageDestroy pcmimg1
End if
EndIf
End Sub
Sub loadbmpputcatcenter(ps1 As String,maxx As Integer,maxy As Integer)
Dim As BITMAPFILEHEADER bmpfh
Dim As BITMAPINFOHEADER bmpih
Dim As Any Ptr pcmimg1
If loadbmpheaderonly(ps1,@bmpfh,@bmpih)=1 Then
If ((bmpih.biWidth*bmpih.biHeight*bmpih.biBitCount) Shr 3)<Fre Then
pcmimg1=ImageCreate(bmpih.biWidth,bmpih.biHeight,0)
BLoad ps1,pcmimg1
Put ((maxx Shr 1)-(bmpih.biWidth Shr 1),(maxy Shr 1)-(bmpih.biHeight Shr 1)),pcmimg1,PSet
ImageDestroy pcmimg1
End if
EndIf
End sub
Function loadbmpheaderonly(fnm As String,bmpfh As BITMAPFILEHEADER ptr,bmpih As BITMAPINFOHEADER Ptr) As Integer
Dim As Integer f,i
If Dir(fnm)="" Then Exit Function
f=FreeFile
Open fnm For Binary As #f
Get #f,1,*CPtr(UByte Ptr,bmpfh),SizeOf(BITMAPFILEHEADER)
Get #f,SizeOf(BITMAPFILEHEADER)+1,*CPtr(UByte Ptr,bmpih),SizeOf(BITMAPINFOHEADER)
Close #f
If bmpih->biWidth<>0 And bmpih->biHeight<>0 Then Function=1 Else Function=2
End Function
Function loadbmp(fnm As String, bmpptrptr As UInteger ptr, w As Integer Ptr, h As Integer Ptr, bits As UByte Ptr,palette1 As Uinteger ptr) As Integer
If bmpptrptr=0 Then Exit Function
Dim As UByte Ptr d6
Dim As UByte Ptr id9,idbested
Dim As Integer ll,j3,jc1,f,i,j,k,x
Dim As UByte j4
Dim As UByte Ptr p
Dim As BITMAPFILEHEADER Ptr bmpfh
Dim As BITMAPINFOHEADER Ptr bmpih
f=FreeFile
Open fnm For Binary As #f
d6=Callocate(SizeOf(BITMAPFILEHEADER)+SizeOf(BITMAPINFOHEADER)+4096)
Get #f,1,*d6,SizeOf(BITMAPFILEHEADER)
bmpfh=d6
Get #f,SizeOf(BITMAPFILEHEADER)+1,d6[SizeOf(BITMAPFILEHEADER)],SizeOf(BITMAPINFOHEADER)
bmpih=@d6[SizeOf(BITMAPFILEHEADER)]
If w<>0 Then *w=bmpih->biWidth
If h<>0 Then *h=bmpih->biHeight
If bits<>0 Then *bits=bmpih->biBitCount
ll=((bmpih->biWidth*bmpih->biHeight*bmpih->biBitCount -1)Shr 3)+1
x=ll
*bmpptrptr=Allocate(ll)
p=*bmpptrptr
Function=ll
'
'for 1,2,4,8 bit mode there also RGBQuad table:
' A table that contains the each color's value in RGB+gamma(4 bytes) (the palette)
' 16/24/32 bit color mode don't need any RGBQuad table ...
'
'bitmaps are 32bit alligned
'first (bmpfh->biWidth*bmpih->biBitCount\8) bytes represent the last line (bottom most).
'each line starts with the pixel at left most (x=0) and goes to right most (x=biWidth-1)
'
ll=(((bmpih->biWidth*bmpih->biBitCount)-1)Shr 3)+1'(((bmpih->biWidth*bmpih->biBitCount-1)Shr 7) Shl 4) +1
ll = (ll And &hfffffffc) + IIf((ll And 3)>0,4,0)
id9=Allocate(ll)
i=bmpih->biHeight-1
j=bmpfh->bfOffBits+1
jc1=(((bmpih->biWidth*bmpih->biBitCount)-1)Shr 3)+1
x-=jc1
Select Case bmpih->biBitCount
Case 1
idbested=allocate(bmpfh->bfSize)
Get #f,1,*idbested,bmpfh->bfSize
while i>0
'Get #f,j,*id9,ll
id9=@idbested[j-1]
k=0
while k<jc1
j4=id9[k]:j3=0
While j3<8
If (j4 And 128)=128 Then
p[k+x]Or=1 Shl j3
Else
p[k+x]And= 255-(1 Shl j3)
EndIf
j3+=1
j4 Shl=1
Wend
k+=1
Wend
x-=jc1
j+=ll
i-=1
Wend
DeAllocate idbested
Case 2
Case 4
while i>0
Get #f,j,*id9,ll
k=0
while k<jc1
j4=id9[k]
p[k+x]=((j4 And 15) Shl 4) Or ((j4 And &hf0) Shr 4)
k+=1
Wend
j+=ll
x-=jc1
i-=1
Wend
Case 8,16,24,32
while i>0
Get #f,j,*id9,ll
movsb1 id9, p+x, jc1
j+=ll
x-=jc1
i-=1
Wend
End Select
DeAllocate id9
DeAllocate d6
Close #f
End Function
Function loadbmpfrommem(src As Any Ptr,srclen As Integer, bmpptrptr As UInteger ptr, w As Integer Ptr, h As Integer Ptr, bits As UByte Ptr,palette1 As Uinteger ptr) As Integer
If bmpptrptr=0 Then Exit Function
If src=0 Or srclen=0 Then Exit Function
Dim As UByte Ptr d6
Dim As UByte Ptr id9,idbested
Dim As Integer ll,j3,jc1,f,i,j,k,x
Dim As UByte j4
Dim As UByte Ptr p
Dim As BITMAPFILEHEADER Ptr bmpfh
Dim As BITMAPINFOHEADER Ptr bmpih
d6=Callocate(SizeOf(BITMAPFILEHEADER)+SizeOf(BITMAPINFOHEADER)+4096)
movsb1 src,d6,SizeOf(BITMAPFILEHEADER)+SizeOf(BITMAPINFOHEADER)
bmpfh=d6
bmpih=@d6[SizeOf(BITMAPFILEHEADER)]
If w<>0 Then *w=bmpih->biWidth
If h<>0 Then *h=bmpih->biHeight
If bits<>0 Then *bits=bmpih->biBitCount
ll=((bmpih->biWidth*bmpih->biHeight*bmpih->biBitCount -1)Shr 3)+1
x=ll
*bmpptrptr=Allocate(ll)
p=*bmpptrptr
Function=ll
'
'for 1,2,4,8 bit mode there also RGBQuad table:
' A table that contains the each color's value in RGB+gamma(4 bytes) (the palette)
' 16/24/32 bit color mode don't need any RGBQuad table ...
'
'bitmaps are 32bit alligned
'first (bmpfh->biWidth*bmpih->biBitCount\8) bytes represent the last line (bottom most).
'each line starts with the pixel at left most (x=0) and goes to right most (x=biWidth-1)
'
ll=(((bmpih->biWidth*bmpih->biBitCount)-1)Shr 3)+1'(((bmpih->biWidth*bmpih->biBitCount-1)Shr 7) Shl 4) +1
ll = (ll And &hfffffffc) + IIf((ll And 3)>0,4,0)
id9=Allocate(ll)
i=bmpih->biHeight-1
j=bmpfh->bfOffBits+1
jc1=(((bmpih->biWidth*bmpih->biBitCount)-1)Shr 3)+1
x-=jc1
Select Case bmpih->biBitCount
Case 1
idbested=allocate(bmpfh->bfSize)
'Get #f,1,*idbested,bmpfh->bfSize
movsb1 src,idbested,bmpfh->bfSize
while i>0
id9=@idbested[j-1]
k=0
while k<jc1
j4=id9[k]:j3=0
While j3<8
If (j4 And 128)=128 Then
p[k+x]Or=1 Shl j3
Else
p[k+x]And= 255-(1 Shl j3)
EndIf
j3+=1
j4 Shl=1
Wend
k+=1
Wend
x-=jc1
j+=ll
i-=1
Wend
DeAllocate idbested
Case 2
Case 4
while i>0
'Get #f,j,*id9,ll
movsb1 CPtr(UByte Ptr,src)+j-1,id9,ll
k=0
while k<jc1
j4=id9[k]
p[k+x]=((j4 And 15) Shl 4) Or ((j4 And &hf0) Shr 4)
k+=1
Wend
j+=ll
x-=jc1
i-=1
Wend
Case 8,16,24,32
while i>0
'Get #f,j,*id9,ll
movsb1 CPtr(UByte Ptr,src)+j-1,id9,ll
movsb1 id9, p+x, jc1
j+=ll
x-=jc1
i-=1
Wend
End Select
DeAllocate id9
DeAllocate d6
'Close #f
End Function
Function hex8(i As ULongInt) As String
Dim As String a=Hex(i)
If Len(a)<2 Then a=String(2-Len(a),"0")+a
Function = a
End Function
Function hex16(i As ULongInt) As String
Dim As String a=Hex(i)
If Len(a)<4 Then a=String(4-Len(a),"0")+a
Function = a
End Function
Function hex24(i As ULongInt) As String
Dim As String a=Hex(i)
If Len(a)<6 Then a=String(6-Len(a),"0")+a
Function = a
End Function
Function hex32(i As ULongInt) As String
Dim As String a=Hex(i)
If Len(a)<8 Then a=String(8-Len(a),"0")+a
Function = a
End Function
Function hex64(i As ULongInt) As String
Dim As String a=Hex(i)
If Len(a)<16 Then a=String(16-Len(a),"0")+a
Function = a
End Function
Sub Printnosound(brom As UByte Ptr, size As UInteger)
Dim As Integer i,c=Color()
For i=0 To size-1
If brom[i]<15 and (brom[i]>6) and ((brom[i]<11 or brom[i]>12)) then 'itmp[i]=8 or itmp[i]=13 or itmp[i]=14 then
color brom[i],brom[i]
print " ";:color c And &hffff,c Shr 16
elseif brom[i]=255 then
color 1,15:print " ";:color c And &hffff,c Shr 16
elseif brom[i]=0 then
color 0,8:print ".";:color c And &hffff,c Shr 16
Else
print chr(brom[i]);
End If
Next i
color c And &hffff,c Shr 16
End Sub
Function tohex1(i As ULongInt) As String
Dim As String d
Do
d=chr(IIf((i And 15)<=9, Asc("1")+(i And 15), (i And 15)+Asc("A")-10))+d
i Shr=4
Loop While i<>0
Function =d+"h"
End Function
sub print_any overload (dump as ubyte)
select case dump
case 0
color 1,8 :print ".";
case 1 to 5, 15 to 254
color 7,0:print chr(dump);
case 255
color 1,15:print " ";
case else
color dump,dump: print " ";
end select
color 7,0
end sub
sub print_any overload (dump as ubyte,sel as ushort)
select case dump
case 0
color sel,8 :print ".";
case 1 to 5, 15 to 254
color 7+sel,0
print chr(dump);
case 255
color sel,15:print " ";
case else
color dump,dump+sel
print " ";
end select
end sub
sub pause1 overload(a as string,x as integer)
print a:while inkey="":sleep x:wend
end sub
sub pause1 overload(a as string)
print a:while inkey="":sleep 333:wend
end sub
sub pause1 overload()
while inkey="":sleep 333:wend
end sub
sub pause1 overload(x as integer)
while inkey="":sleep x:wend
end sub
sub shottofile(fnm as string)
Dim As UShort Ptr sup=allocate(80*25*2)
Dim As Integer purcarea=FreeFile
dos_screenshot(sup,80,25)
Open fnm For Binary As #purcarea
Put #purcarea,1,*CPtr(UByte Ptr,sup),80*25*2
Close #purcarea
deallocate sup
end sub
sub print_constraint (a as string,start as integer, l as integer)
dim as string c
c=a
while len(c)>(l)
locate ,start
print left(c,l)
c=right(c,len(c)-l)
wend
if c<>"" then
locate ,start
print c;
end if
end sub
function smart_find(a as string, s as string) as string
'devide s to blocks of type: (note : '*' can mean also no character)
'|?s?|
'|?s*|
'|*s?|
'|*s*|
dim as string f(1 to len(s))
dim as string c
dim as integer i,j,k
i=instr(s,"?")
k=instr(s,"*")
if i>0 and k>0 and k>i then
j+=1
f(j)="*"+mid(s,i,k-i-1)+"?"
elseif i>0 and k>0 and i>k then
j+=1
f(j)="?"+mid(s,i,k-i-1)+"*"
end if
end function
dim shared as integer maxcol=80
SUB TextXY (x as integer, y as integer, Txt as string)
LOCATE y, x
PRINT Txt
END SUB
SUB MsgBox (text as string, nume as string)
dim as string adeon
if len(text)>74 then
adeon=mid(text,77,len(text)-74)
text=left(text,74)
end if
COLOR 2+8, 7
Center 11, SPACE$(LEN(text) + 4)
TextXY (maxcol Shr 1) - LEN(text) \ 2 - 3, 11, nume
COLOR 15, 2
Center 12, SPACE$(LEN(text) + 4)
Center 13, SPACE$(LEN(text) + 4)
Center 14, SPACE$(LEN(text) + 4)
if adeon<>"" then
center 15,SPACE$(LEN(text) + 4)
end if
COLOR 4, 7
TextXY (maxcol Shr 1) + LEN(text) \ 2, 11, "X"
COLOR 15, 2
if adeon<>"" then
locate 13,3:print text;
locate 14,3:print adeon;
else
Center 13, text
end if
WHILE InKey = "":sleep 333: WEND
END SUB
SUB Win (x1 as integer, y1 as integer, x2 as integer, y2 as integer, name1 as string,tc as integer, tb as integer)
dim as integer i
LOCATE y1, x1
color tc,tb
PRINT chr(201); string(x2-x1+1-2,chr(205)); chr(187);
COLOR tb, tc
LOCATE y1, (maxcol Shr 1) - (LEN(name1) / 2)
PRINT name1;
color tc,tb
FOR i = (y1 + 1) TO (y2 - 1)
IF (x2-x1+1> maxcol-2) AND (x2-x1+1 < maxcol) THEN
LOCATE i, x1
PRINT chr(186); SPACE(x2-x1+1 - 2); chr(186);
continue for
END IF
LOCATE i, x1
PRINT chr(186); SPACE$(x2-x1+1 - 2); chr(186);
NEXT i
LOCATE y2, x1
PRINT chr(200); string((x2-x1+1 - 2),chr(205)); chr(188);
color tc,tb
END SUB
SUB CenterC (row as integer , text as String)
dim as integer xx
xx = ((maxcol-LEN(text)) shr 1) + 1
Locate row, xx
PRINT text
END SUB
SUB Center (row as integer , text as String)
dim as integer xx
xx = ((maxcol-LEN(text)) shr 1) - 1
Locate row, xx
PRINT text
END SUB
SUB CenterNL (row as integer , text as String)
dim as integer xx
xx = ((maxcol-LEN(text)) shr 1) - 1
Locate row, xx
PRINT text;
END SUB
function dealloc2(a as any ptr) as integer
function=deallocate2(a)
end function
function get_smart(predef as string, x as integer, y as integer) as string
dim as string my=predef
dim as string a
dim as integer w=x
dim as integer i,k,j,ledd=len(my)
dim as integer t=y
Do
locate y,x,1
print my;" ";
if x+ledd>maxcol then
w=ledd+x - maxcol*((ledd+x)\maxcol)
t=y+(x+ledd)\maxcol
else
t=y
w=x+ledd
end if
locate t,w
a=inkey
sleep 1
while a="":a=inkey:j+=1: sleep j: if j>10 then j=10
wend
select case a
case Chr(255,72),chr(0,72)'up
if len(my)>=ledd then
mid(my,ledd,1)=chr(asc(mid(my,ledd,1))+1)
else
my+=chr(1)
end if
case Chr(255,80),chr(0,80)'down
if len(my)>=ledd then
mid(my,ledd,1)=chr(asc(mid(my,ledd,1))-1)
else
my+=chr(255)
end if
Case Chr(255,75),chr(0,75)'left
ledd-=1
if ledd <0 then ledd=0
Case Chr(255,77),chr(0,77)'right
ledd+=1
if ledd >len(my) then ledd=len(my)
case chr(8) 'backspace
my=left(my,iif(ledd-1>=0,ledd-1,0))+right(my,len(my)-ledd)
ledd-=1
if ledd < 0 then ledd=0
case chr(9) 'tab
case chr(13) 'enter
case chr(27) 'esc
case chr(255,83),chr(0,83) 'delete
my=left(my,ledd)+right(my,iif(len(my)-ledd-1>=0,len(my)-ledd-1,0))
case else
if len(a)=1 then
my=left(my,ledd)+a+right(my,len(my)-ledd)
ledd+=1
end if
end select
loop until a=chr(13) or a=chr(27)
function=my
End Function
function get_smart overload (predef as string, x as integer, y as integer, helptext as zstring ptr) as string
dim as string my=predef
dim as string a
dim as integer w=x
dim as integer i,k,j,ledd=len(my)
dim as integer t=y
do
locate y,x
print my;" ";
if x+ledd>maxcol then
w=ledd+x - maxcol*((ledd+x)\maxcol)
t=y+(x+ledd)\maxcol
else
t=y
w=x+ledd
end if
locate t,w
a=inkey
sleep 1
while a="":a=inkey:j+=1: sleep j: if j>10 then j=10
wend
select case a
case Chr(255,72),chr(0,72)'up
if len(my)>=ledd then
mid(my,ledd,1)=chr(asc(mid(my,ledd,1))+1)
else
my+=chr(1)
end if
case Chr(255,80),chr(0,80)'down
if len(my)>=ledd then
mid(my,ledd,1)=chr(asc(mid(my,ledd,1))-1)
else
my+=chr(255)
end if
Case Chr(255,75),chr(0,75)'left
ledd-=1
if ledd <0 then ledd=0
Case Chr(255,77),chr(0,77)'right
ledd+=1
if ledd >len(my) then ledd=len(my)
case chr(255,59),chr(0,59)'F1
dim as ushort ptr upi=allocate(80*25 shl 1)
#ifdef __FB_DOS__
dos_screenshot upi,80,25
#endif
win 10,4,70,21,"Help",14,0
locate 5,11:color 7,0
print_constraint *helptext,11,58
pause1
#ifdef __FB_DOS__
dos_screenload upi,80,25
#endif
dealloc2 @upi
case chr(8) 'backspace
my=left(my,iif(ledd-1>=0,ledd-1,0))+right(my,len(my)-ledd)
ledd-=1
if ledd < 0 then ledd=0
case chr(9) 'tab
case chr(13) 'enter
case chr(27) 'esc
case chr(255,83),chr(0,83) 'delete
my=left(my,ledd)+right(my,iif(len(my)-ledd-1>=0,len(my)-ledd-1,0))
case else
if len(a)=1 then
my=left(my,ledd)+a+right(my,len(my)-ledd)
ledd+=1
end if
end select
loop until a=chr(13) or a=chr(27)
function=my
end Function
Sub get_likecombo overload (txt as string,ot1 as any ptr, info as integer ptr,x as integer, y as integer, textc as uinteger, backc as uinteger, helptext as zstring Ptr,ByRef sel As Integer=1)
dim as zstring ptr output1=ot1
dim as integer ent_cnt,i,k,j,longest
dim as string keyb
i=1
while instr(i,txt,"[")>0 and i<len(txt)
ent_cnt+=1
i=instr(i,txt,"]")
if i=0 then exit while
i+=1
wend
dim as string aa(1 to ent_cnt)
dim as string ii(1 to ent_cnt)
i=1
k=0
while instr(i,txt,"[")>0 and i<len(txt) and k<ent_cnt
k+=1
aa(k)=mid(txt,instr(i,txt,"[")+1,instr(i,txt,"]") -instr(i,txt,"[")-1)
if instr(aa(k),":")>0 then ii(k)=right(aa(k),len(aa(k))-instr(aa(k),":"))
if len(aa(k)) >longest then longest=len(aa(k))
i=instr(i,txt,"]")
if i=0 then exit while
i+=1
wend
If sel<1 Then sel=1
do
color textc,backc
locate y,x
print "[ ";aa(sel);space(longest-len(aa(sel)));chr(18);"]";
keyb=inkey
sleep 1
while keyb="": keyb=inkey: sleep j: j+=1: if j>100 then j=100
wend
select case keyb
case Chr(255,72),chr(0,72)'up
sel-=1
if sel <1 then sel=ent_cnt
case Chr(255,80),chr(0,80)'down
sel+=1
if sel>ent_cnt then sel=1
Case Chr(255,75),chr(0,75)'left
Case Chr(255,77),chr(0,77)'right
case chr(255,59),chr(0,59)'F1
dim as ushort ptr upi=allocate(80*25 shl 1)
#ifdef __FB_DOS__
dos_screenshot upi,80,25
#endif
win 10,4,70,21,"Help",14,0
locate 5,11:color 7,0
print_constraint *helptext,11,58
pause1
#ifdef __FB_DOS__
dos_screenload upi,80,25
#endif
dealloc2 @upi
case chr(13)
*output1=aa(sel)+chr(0)
*info=val(ii(sel))
case chr(27)
*output1=chr(0)
*info=0
end select
loop until keyb=chr(27) or keyb=chr(13)
color 7,0
if ent_cnt>=10000 then print "Deallocating (it will take a little longer ... because ...)"
end sub
Sub get_likecombo overload (txt as string,ot1 as any ptr, info as integer ptr,x as integer, y as integer, textc as uinteger, backc as UInteger, ByRef sel As Integer=1)
dim as zstring ptr output1=ot1
dim as integer ent_cnt,i,k,j,longest
dim as string keyb
i=1
while instr(i,txt,"[")>0 and i<len(txt)
ent_cnt+=1
i=instr(i,txt,"]")
if i=0 then exit while
i+=1
wend
dim as string aa(1 to ent_cnt)
dim as string ii(1 to ent_cnt)
i=1
k=0
while instr(i,txt,"[")>0 and i<len(txt) and k<ent_cnt
k+=1
aa(k)=mid(txt,instr(i,txt,"[")+1,instr(i,txt,"]") -instr(i,txt,"[")-1)
if instr(aa(k),":")>0 then ii(k)=right(aa(k),len(aa(k))-instr(aa(k),":"))
if len(aa(k)) >longest then longest=len(aa(k))
i=instr(i,txt,"]")
if i=0 then exit while
i+=1
wend
If sel<1 Then sel=1
do
color textc,backc
locate y,x
print "[ ";aa(sel);space(longest-len(aa(sel)));chr(18);"]";
keyb=inkey
sleep 1
while keyb="": keyb=inkey: sleep j: j+=1: if j>100 then j=100
wend
select case keyb
case Chr(255,72),chr(0,72)'up
sel-=1
if sel <1 then sel=ent_cnt
case Chr(255,80),chr(0,80)'down
sel+=1
if sel>ent_cnt then sel=1
Case Chr(255)+"K"'left
Case Chr(255)+"M"'right
case chr(13)
*output1=aa(sel)+chr(0)
*info=val(ii(sel))
case chr(27)
*output1=chr(0)
*info=0
end select
loop until keyb=chr(27) or keyb=chr(13)
color 7,0
if ent_cnt>=10000 then print "Deallocating (it will take a little longer ... because ...)"
end sub
function from_hex (a as string) as ulongint
dim as ulongint i
dim as UByte k
Dim As UByte bu1,bu2,l
Dim As UByte c
a=lcase(a)
if left(a,2)="0x" then
a=right(a,len(a)-2)
Elseif left(a,2)="&h" then
a=right(a,len(a)-2)
elseif right(a,1)="h" then
a=left(a,len(a)-1)
EndIf
bu2=97-10
i=0
k=1:l=Len(a)
c=(l-k) Shl 2
While k<=l
bu1=Asc(a,k) 'p[k]
If bu1>=48 AndAlso bu1<=57 Then
bu1-=48
ElseIf bu1>=97 AndAlso bu1<=102 Then
bu1-=bu2
Else
Exit While 'a different char; we reached end of number or syntax error
EndIf
i or=(bu1 Shl c)
c-=4
k+=1
Wend
Function=i
End Function
function from_hex2str (a as string) as String
If LCase(Left(a,2))="0x" Then Return Str(from_hex(a))
If LCase(Left(a,2))="&h" Then Return Str(from_hex(a))
If LCase(right(a,1))="h" Then Return Str(from_hex(a))
Return a
End Function
function get_sel(num as integer,txt as string) as string
dim as integer cnt,i
i=1
while instr(i,txt,"[")>0 and i<len(txt)
if instr(i,txt,"[")>0 then
cnt+=1
if cnt=num then
function=mid(txt,instr(i,txt,"[")+1,instr(i,txt,"]")-instr(i,txt,"[")-1)
exit function
end if
i=instr(i,txt,"]")+1
end if
wend
end function
function deallocate2(a as any ptr) as integer
if *cptr(uinteger ptr, a)<>0 then
deallocate *cptr(uinteger ptr, a)
*cptr(uinteger ptr, a)=0
end if
end Function
Sub dos_screenshot(Scrn As UShort Ptr, w As Integer, h As Integer)
If Scrn=0 Then Exit Sub
If w=0 then w=80
If h=0 Then h=25
#Ifdef __FB_DOS__
dosmemget &hb8000,w*h*2,Scrn
#endif
End Sub
Sub dos_screenload(Scrn As UShort Ptr, w As Integer, h As Integer)
If Scrn=0 Then Exit Sub
If w=0 then w=80
If h=0 Then h=25
#ifdef __FB_DOS__
dosmemput Scrn,w*h*2,&hb8000
#else
dim as integer i
for i=0 to w*h-1
color ((scrn[i] shr 8) and &hf),(scrn[i] shr 12)
print_any(scrn[i] and &hff)
next i
#EndIf
End Sub
#Ifdef __FB_DOS__
function menu_get_opt(entries as string, x as integer, y as integer,textc as integer, backc as Integer,Byref sel As Integer=1) as string
dim as integer i,k,j,longest' ,sel
dim as integer ent_num,bubu,mox,moy,nomouse
dim as uinteger mu
dim as string a
getmouse mox,moy,,bubu
if mox=-1 and moy=-1 and bubu=-1 then nomouse=1
mox=39:moy=12:bubu=0
i=1
while i<=len(entries) and i >0
if instr(i,entries,"[")>0 then
ent_num+=1
i=instr(i,entries,"]")+1
endif
wend
dim as string aa(1 to ent_num)
i=1
k=0
while i<=len(entries) and i>0
if instr(i,entries,"[")>0 then
k+=1
aa(k)=mid(entries,i+1,instr(i,entries,"]")-i-1)
if len(aa(k))>longest then longest=len(aa(k))
i=instr(i,entries,"]") +1
endif
wend
If sel<1 Then sel=1
if ent_num >0 then
do
for i=1 to ent_num
locate y+i-1,x
if i<>sel then
color 15,backc
print "[ ";
color textc,backc
print aa(i);space(longest-len(aa(i))+1);
color 15,backc
print "]"
else
color 15,textc
print "[ ";
color backc,textc
print aa(i);space(longest-len(aa(i))+1);
color 15,textc
print "]"
end if
next i
a=""
a=inkey
sleep 1
j=1
if nomouse=0 then getmouse mox,moy,,bubu
while a="" and bubu=0
if nomouse=0 then getmouse(mox,moy,,bubu)
dosmemget &hb8000+(mox+moy*80)*2,2,@mu
locate moy+1,mox+1
color 15-((mu shr 8) and &hf),15-((mu shr 12) and &hf)
print chr(mu and &hff);
a=inkey: sleep j: j+=1:
locate moy+1,mox+1
color ((mu shr 8) and &hf),(mu shr 12) and &hf
print chr(mu and &hff);
if j>50 then j=50
wend
select case a
case Chr(255)+"H"'up
sel-=1
if sel <1 then sel=ent_num
case Chr(255)+"P"'down
sel+=1
if sel>ent_num then sel=1
Case Chr(255)+"K"'left
Case Chr(255)+"M"'right
end select
if bubu<>0 then
if (moy+1>=y) and (moy+1<=y+ent_num-1) and _
(mox+1>=x) and (mox+1<=longest+4+x) then
if sel=(moy+1)-y +1 then exit do
sel=(moy+1)-y +1
bubu=0
if sel<1 then sel=1
if sel>ent_num then sel=ent_num
sleep 100
end if
end if
loop until a= chr(13) or a=chr(27)
if sel>0 and sel<= ent_num and a<>chr(27) then function=aa(sel)
locate y+ent_num,1
endif
color 7,0
end Function
#Else
Function menu_get_opt_drawonly(entries as string, x as integer, y as integer,textc as integer, backc as Integer, Byref sel As Integer=1) as string
dim as integer i,k,j,longest',sel
dim as integer ent_num
dim as string a
i=1
while i<=len(entries) and i >0
if instr(i,entries,"[")>0 then
ent_num+=1
i=instr(i,entries,"]")+1
endif
wend
dim as string aa(1 to ent_num)
i=1
k=0
while i<=len(entries) and i>0
if instr(i,entries,"[")>0 then
k+=1
aa(k)=mid(entries,i+1,instr(i,entries,"]")-i-1)
if len(aa(k))>longest then longest=len(aa(k))
i=instr(i,entries,"]") +1
endif
wend
If sel<1 Then sel=1
if ent_num >0 then
for i=1 to ent_num
locate y+i-1,x
if i<>sel then
color 15,backc
print "[ ";
color textc,backc
print aa(i);space(longest-len(aa(i))+1);
color 15,backc
print "]"
else
color 15,textc
print "[ ";
color backc,textc
print aa(i);space(longest-len(aa(i))+1);
color 15,textc
print "]"
end if
next i
If sel>0 and sel<= ent_num and a<>chr(27) then function=aa(sel)
locate y+ent_num,1
endif
color 7,0
End function
function menu_get_opt(entries as string, x as integer, y as integer,textc as integer, backc as Integer, Byref sel As Integer=1) as string
dim as integer i,k,j,longest',sel
dim as integer ent_num
dim as string a
i=1
while i<=len(entries) and i >0
if instr(i,entries,"[")>0 then
ent_num+=1
i=instr(i,entries,"]")+1
endif
wend
dim as string aa(1 to ent_num)
i=1
k=0
while i<=len(entries) and i>0
if instr(i,entries,"[")>0 then
k+=1
aa(k)=mid(entries,i+1,instr(i,entries,"]")-i-1)
if len(aa(k))>longest then longest=len(aa(k))
i=instr(i,entries,"]") +1
endif
wend
If sel<1 Then sel=1
if ent_num >0 then
do
for i=1 to ent_num
locate y+i-1,x
if i<>sel then
color 15,backc
print "[ ";
color textc,backc
print aa(i);space(longest-len(aa(i))+1);
color 15,backc
print "]"
else
color 15,textc
print "[ ";
color backc,textc
print aa(i);space(longest-len(aa(i))+1);
color 15,textc
print "]"
end if
next i
a=""
a=inkey
sleep 1
j=1
while a="": a=inkey: sleep j: j+=1: if j>100 then j=100
wend
select case a
case Chr(255)+"H"'up
sel-=1
if sel <1 then sel=ent_num
case Chr(255)+"P"'down
sel+=1
if sel>ent_num then sel=1
Case Chr(255)+"K"'left
Case Chr(255)+"M"'right
end select
loop until a= chr(13) or a=chr(27)
if sel>0 and sel<= ent_num and a<>chr(27) then function=aa(sel)
locate y+ent_num,1
endif
color 7,0
end function
#endif
[please look to my next reply ... I could not post all of them at once ... thanks for understanding ]