Parabolic Mirror/Shape

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
Mihail_B
Posts: 273
Joined: Jan 29, 2008 11:20
Location: Romania
Contact:

Parabolic Mirror/Shape

Post by Mihail_B »

Here's a part of my [jonction2] project:
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
the adjuvant 1 : [easy.bas]

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
the adjuvant 2: [mem.bas]

[please look to my next reply ... I could not post all of them at once ... thanks for understanding ]
Last edited by Mihail_B on Oct 15, 2011 7:24, edited 6 times in total.
Ivan, Zagreb
Posts: 16
Joined: Oct 04, 2011 19:44
Location: Croatia

Re: Parabolic Mirror/Shape

Post by Ivan, Zagreb »

the adjuvant 1 : [easy.bas]

Code: Select all

#Include Once "mem.bas"
error 24: File not found, "mem.bas" in '#Include Once "mem.bas"
No "mem.bas" in my computer :(
Mihail_B
Posts: 273
Joined: Jan 29, 2008 11:20
Location: Romania
Contact:

Re: Parabolic Mirror/Shape

Post by Mihail_B »

Ivan, Zagreb wrote:
the adjuvant 1 : [easy.bas]

Code: Select all

#Include Once "mem.bas"
error 24: File not found, "mem.bas" in '#Include Once "mem.bas"
No "mem.bas" in my computer :(
And [mem.bas]

Code: Select all

'SDSMST signature for disk errors = this is file [mem.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 thanks : OCW.MIT.EDU
'

#Ifndef MEM_BAS
#Define MEM_BAS
declare sub movsb1(src as any ptr,dst as any ptr,l as uinteger) 'movs arrays
declare function cmpsb1(src as any ptr, dst as any ptr, l as uinteger) as integer 'compares strings
declare function scasb1(c as ubyte,dst as any ptr,l as uinteger) as integer 'compares byte with all bytes in dst
declare sub stosb1(c as ubyte, dst as any ptr, l as uinteger) 'stores byte into dst many times
declare sub stosw1(c as ushort, dst as any ptr, l as uinteger) 'stores byte into dst many times
declare sub stosd1(c as uinteger, dst as any ptr, l as uinteger) 'stores byte into dst many times

declare Function inw_PCI_reg(bus As UByte,dev As UByte, func As UByte, reg As UByte) As UShort
declare Function ind_PCI_reg(bus As UByte,dev As UByte, func As UByte, reg As UByte) As UInteger
declare Sub outw_PCI_reg(bus As UByte,dev As UByte, func As UByte, reg As UByte , d2 As Ushort)
declare Sub outd_PCI_reg(bus As UByte,dev As UByte, func As UByte, reg As UByte , d2 As UInteger)
declare function inb1(p as uinteger) as ubyte
declare function inw1(p as uinteger) as ushort
declare function ind1(p as uinteger) as uinteger
declare sub outb1(p as uinteger, d as ubyte)
declare sub outw1(p as uinteger, d as ushort)
declare sub outd1(p as uinteger, d as uinteger)
declare function incmosrtc(port as ubyte) as ubyte
declare Sub outcmosrtc(port as ubyte, value as ubyte)
declare sub sound_on(s as ushort)
declare sub sound_off()
declare function hard_readkey() as ushort
declare sub stop_fd_motor()
declare sub ide0_standby()
declare sub ide1_standby()
declare sub ide1_idle()
declare sub ide0_idle()
Declare sub rdtsc1(i as ulongint ptr)
declare function inkey1() as ushort

'EFS (ElectroFileSystem - yet another filesystem, but for flashes(devices that can be re-programed only a limited number of times like 10000)
'EFS is simple (made by me) but optimized for NAND flashes.
'You can find full detail about efs in OSAK1025(ElectroZ80) operating system (my OS) for Mp4 players ...
'Project name : electronz80.sourceforge.net (also in giveio_bas.bas)
Type  file_entry
    As ZString*16 filename
    As UByte attributes
    As UByte addit(2)
    As UInteger starting_page
    As UInteger size
    As UInteger reserved
End Type
Type last_entry_in_dir
    As UInteger previous_page
    As UInteger next_page
    As UInteger overwrite1_previous_page
    As UInteger overwrite1_next_page
    As UInteger overwrite2_previous_page
    As UInteger overwrite2_next_page
    As UInteger overwrite3_previous_page
    As UInteger overwrite3_next_page
End Type

#ifdef __FB_DOS__
declare function get_physical(ada as uinteger,where as any ptr, size as uinteger) as integer
Function get_physical(ada as uinteger,where as any ptr, size as uinteger) as integer
 dim as uinteger adb=0
 dim as uinteger adc1,add1
 asm
        pushad
        mov eax,&h800
        mov bx,[ada+2]
        mov cx,[ada]
        mov esi,[size]
        shr esi,16
        mov di,[size]
        int &h31
        jc _notalloc
        mov [adb],cx
        mov [adb+2],bx
        mov eax,&h0504
        shl ebx,16
        and ecx,&hffff
        or ebx,ecx
        mov ecx,1
        mov edx,1
        int &h31
        jc _notalloc
        end asm

        'sound_on(&h100)
        asm
        mov [adc1],ebx
        mov [add1],esi
        _notalloc:
        popad
end asm

if adc1<>0 then
        locate 2,60
        print hex(adc1);" ";
        movsb1 adc1,where,size
        asm
                pushad
                mov eax,&h0502
                mov di,[add1]
                mov si,[add1+2]
                int &h31
                popad
        end asm
end if
if adb<>0 then
         asm
                pushad
                mov eax,&h0801
                mov cx,[adb]
                mov bx,[adb+2]
                int &h31
                popad
         end asm
end if
end function
#endif
function inkey1() as ushort
 dim as ushort i
 asm
        push ax
        in al,&h64
        mov [i+1],al
        in al,&h60
        mov [i],al
        pop ax
 end asm
 function=i
end function
sub rdtsc1(i as ulongint ptr)
	Asm
        push eax
        push edx
        push ecx
        rdtsc
        mov ecx,[i]
        mov [ecx],eax
        mov [ecx+4],edx
        pop ecx
        pop edx
        pop eax
	End asm
end Sub
Sub ide0_standby()
asm
        push ax
        push dx
        mov al,&h96
        mov dx,&h1f7
        out dx,al
        pop dx
        smsw ax
        bt ax,0
        jc _in_pmi0s
        _in_pmi0s:
        pop ax
end asm
end sub

sub ide1_standby()
asm
        push ax
        push dx
        mov al,&h96
        mov dx,&h177
        out dx,al
        pop dx
        smsw ax
        bt ax,0
        jc _in_pmi1s
        _in_pmi1s:
        pop ax
end asm
end sub

sub ide0_idle()' ;wake
asm
        push ax
        push dx
        _wait777:
        mov dx,&h1f1
        in al,dx
        add dx,6
        in al,dx
        cmp al,128
        jnbe _wait777
        mov al,&h97
        mov dx,&h1f7
        out dx,al
        pop dx
        pop ax
end asm
end sub
sub ide1_idle() 'wake
asm
        push ax
        push dx
        _wait7772:
        mov dx,&h171
        in al,dx
        add dx,6
        in al,dx
        cmp al,128
        jnbe _wait7772
        mov al,&h97
        mov dx,&h177
        out dx,al
        pop dx
        pop ax
end asm
end sub
' Kill the floppy motor.
' This code was shamelessly stolen from Linux.
sub stop_fd_motor()
asm
        push ax
        push dx
        xor     al, al
        mov dx,&h3f2
        out dx,al
        pop dx
        pop ax
end asm
end sub

function hard_readkey() as ushort
 dim as ushort dat
 asm
        in al,&h64
        mov [dat+1],al
        in al,&h60    ';output AX ; AL - key code , AH - extended info from &h64
        mov [dat],al
 end asm
 function=dat
end function

sub sound_on(s as ushort)
 asm
        push ax
        in al,&h61
        or al, 3        ' PC Speaker BEEP
        out &h61,al
        mov al,&hb6
        out &h43,al
        mov al,[s]  'fr_lowbyte   ;freq = 1193181 \ real_freq
        out &h42,al
        mov al,[s+1]  'fr_hibyte
        out &h42,al
        pop ax
 end asm
end sub
sub sound_off()
 asm
        push ax
        in al,&h61
        and al,&hf1
        out &h61,al
        pop ax
 end asm
end sub
function incmosrtc(port as ubyte) as ubyte
         dim as ubyte old
         old=inb1(&h70)
         outb1 &h70, port or (old and &h80)
         function=inb1(&h71)
         outb1 &h70,old
end function
Sub outcmosrtc(port as ubyte, value as ubyte)
         dim as ubyte old
         old=inb1(&h70)
         outb1 &h70, port or (old and &h80)
         outb1 &h71, value
         outb1 &h70,old
end sub
sub stosw1(c as ushort, dst as any ptr, l as uinteger)
        asm
                push edi
                push ecx
                push eax
                pushf
                mov edi,[dst]
                mov ecx,[l]
                mov al,[c]
                cld
                rep stosw
                popf
                pop eax
                pop ecx
                pop edi
        end asm
End Sub
Sub stosd1(c as uinteger, dst as any ptr, l as uinteger)
        asm
                push edi
                push ecx
                push eax
                pushf
                mov edi,[dst]
                mov ecx,[l]
                mov al,[c]
                cld
                rep stosd
                popf
                pop eax
                pop ecx
                pop edi
        end asm

End Sub


sub stosb1(c as ubyte, dst as any ptr, l as uinteger)
        asm
                push edi
                push ecx
                push eax
                pushf
                mov edi,[dst]
                mov ecx,[l]
                mov al,[c]
                cld
                rep stosb
                popf
                pop eax
                pop ecx
                pop edi
        end asm
end sub
function scasb1(c as ubyte,dst as any ptr,l as uinteger) as integer
dim as UInteger d
        asm
                push edi
                push ecx
                push eax
                pushf
                mov edi,[dst]
                mov ecx,[l]
                mov al,[c]
                cld
                repne scasb
                je _okay_scascd
                mov dword ptr [d], 0
                jmp Short _okay_dscasb
                _okay_scascd:
                mov eax,[l]
                Sub eax,ecx
                'dec eax
                mov dword ptr [d],eax
                _okay_dscasb:
                popf
                pop eax
                pop ecx
                pop edi
        end asm
        function = d
end function
sub movsb1(src as any ptr,dst as any ptr,l as uinteger)
        Asm
                push esi
                push edi
                push ecx
                pushf
                mov esi,[src]
                mov edi,[dst]
                mov ecx,[l]
                cld
                rep movsb
                popf
                pop ecx
                pop edi
                pop esi
        End Asm
end sub
function cmpsb1(src as any ptr, dst as any ptr, l as uinteger) as integer
        dim as integer r=1
        asm
                push esi
                push edi
                push ecx
                pushf
                mov esi,[src]
                mov edi,[dst]
                mov ecx,[l]
                cld
                repe cmpsb
                je _eeeeee1
                mov dword ptr [r],0
                _eeeeee1:
                popf
                pop ecx
                pop edi
                pop esi
        end asm
        function=r
end function
Function inw_PCI_reg(bus As UByte,dev As UByte, func As UByte, reg As UByte) As UShort
	Dim As UInteger d1,d2
	d1=(reg Shl 2)+(func Shl 8)+(dev Shl 11) + (bus Shl 16)
	d1=BitSet(d1,31)
	Asm
	    push eax
	    push edx
		mov dx,&hcf8
		mov eax,[d1]
		Out dx,eax
		mov dx,&hcfc
		in ax,dx
		mov [d2],ax
	    pop edx
	    pop eax
		
	End Asm
	Function=Cast(UShort,d2)
End Function
Function ind_PCI_reg(bus As UByte,dev As UByte, func As UByte, reg As UByte) As UInteger
Dim As UInteger d1,d2
	d1=(reg Shl 2)+(func Shl 8)+(dev Shl 11) + (bus Shl 16)
	d1=BitSet(d1,31)
	Asm
	    push eax
	    push edx
	
		mov dx,&hcf8
		mov eax,[d1]
		Out dx,eax
		mov dx,&hcfc
		in eax,dx
		mov [d2],eax
    	
	    pop edx
	    pop eax

	End Asm
	Function=d2
End Function
Sub outw_PCI_reg(bus As UByte,dev As UByte, func As UByte, reg As UByte , d2 As Ushort)
Dim As UInteger d1
	d1=(reg Shl 2)+(func Shl 8)+(dev Shl 11) + (bus Shl 16)
	d1=BitSet(d1,31)
	Asm
	    push eax
	    push edx

		mov dx,&hcf8
		mov eax,[d1]
		Out dx,eax
		mov dx,&hcfc
		mov ax,[d2]
		out dx,ax
	    pop edx
	    pop eax
End Asm
End Sub
Sub outd_PCI_reg(bus As UByte,dev As UByte, func As UByte, reg As UByte , d2 As UInteger)
Dim As UInteger d1
	d1=(reg Shl 2)+(func Shl 8)+(dev Shl 11) + (bus Shl 16)
	d1=BitSet(d1,31)
	Asm
	    push eax
	    push edx
		mov dx,&hcf8
		mov eax,[d1]
		Out dx,eax
		mov dx,&hcfc
		mov eax,[d2]
		out dx,eax
	    pop edx
	    pop eax
	End Asm
End Sub

function inb1(p as uinteger) as ubyte
dim as ubyte d
        asm
        push dx
        push ax
        mov dx,[p]
        in al,dx
        mov [d],al
        pop ax
        pop dx
end asm
function=d
end function
function inw1(p as uinteger) as ushort
dim as ushort d
        asm
        push dx
        push ax
        mov dx,[p]
        in ax,dx
        mov [d],ax
        pop ax
        pop dx
end asm
function=d
end function
function ind1(p as uinteger) as uinteger
dim as uinteger d
        asm
        push dx
        push eax
        mov dx,[p]
        in eax,dx
        mov [d],eax
        pop eax
        pop dx
end asm
function=d
end function
sub outb1(p as uinteger, d as ubyte)
        asm
        push dx
        push ax
        mov dx,[p]
        mov al,[d]
        out dx,al
        pop ax
        pop dx
end asm
end sub
sub outw1(p as uinteger, d as ushort)
        asm
        push dx
        push ax
        mov dx,[p]
        mov ax,[d]
        out dx,ax
        pop ax
        pop dx
end asm
end sub
sub outd1(p as uinteger, d as uinteger)
        asm
        push dx
        push eax
        mov dx,[p]
        mov eax,[d]
        out dx,eax
        pop eax
        pop dx
end asm
end sub

#EndIf
pestery
Posts: 493
Joined: Jun 16, 2007 2:00
Location: Australia

Post by pestery »

Nice.

I had to make one small change though to get it to work. About line 70 in parabolic.bas there is a line that tests the amount of free memory. I had to add CUInt to it because Fre returned more than 2GB.

Code: Select all

If CUInt(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
counting_pine
Site Admin
Posts: 6323
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Post by counting_pine »

Note: a couple of the strings aren't closed in the parabolic.bas code (the compiler should warn you about that.)
t looks like an interesting program, but the dependencies look a little scary.. is it possible to get working using FB's native graphics library?
Mihail_B
Posts: 273
Joined: Jan 29, 2008 11:20
Location: Romania
Contact:

Post by Mihail_B »

counting_pine wrote:Note: a couple of the strings aren't closed in the parabolic.bas code (the compiler should warn you about that.)
t looks like an interesting program, but the dependencies look a little scary.. is it possible to get working using FB's native graphics library?
Not all the functions inside [easy.bas]&[mem.bas] are used by [parabolic.bas] ...

I'll make a shorter version and post it right here ...
([easy.bas]&[mem.bas] are my everyday,everyprogram, headers - my toolkits... I never write a program with out them :) )

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 "mem.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))))
'-adjuvant-
'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)
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

dim shared  as integer maxcol=80
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

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
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
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+=(bu1 Shl c)
    c-=4
    k+=1
 Wend
 Function=i
End Function

'-end of adjuvant
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 CUInt(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
Last edited by Mihail_B on Oct 15, 2011 6:58, edited 2 times in total.
frisian
Posts: 249
Joined: Oct 08, 2009 17:25

Post by frisian »

Mihail_B

I looked at your listing purely out of curiosity , have not much use for it, when a came across the function from_hex in the file paraboli c.bas (second version).
With the first part there is not much wrong but the last part
that converts the string into a UlongInt can be made faster and simpler when ValULng is used.

I have made two versions, the first one with comments
and the second one with out the comments

Code: Select all

Function from_hex (a As String) As ULongInt
	' Dim As ULongInt i	' not needed
	Dim As UInteger k

	a = LCase(a)		' needed, so do it first

	'If LCase(Left(a,2))="0x" Then a=Right(a,Len(a)-2)
	'If LCase(Left(a,2))="&h" Then a=Right(a,Len(a)-2)
	'If LCase(Right(a,1))="h" Then a=Left(a,Len(a)-1)

	' now we can remove LCase() from the If Then statements

	If Left(a,2)="0x" Then a=Right(a,Len(a)-2)
	If Left(a,2)="&h" Then a=Right(a,Len(a)-2)
	If Right(a,1)="h" Then a=Left(a,Len(a)-1)

	' a=LCase(a)		' moved to the top

	If Len(a)>16 Then a=Right(a,16)
	' if Len(a) > 16 is true the number is too big, better abort and report number is too big

	' k=Len(a)		'makes no sense

	For k=1 To Len(a)
		Select Case Mid(a,k,1)
		        Case_  "0","1","2","3","4","5","6","7","8","9","a","b","c","d","e","f"
			Case Else
				Return 0
		End Select
	Next

	' better replace it with something simpler and faster
	' For k=1 To Len(a)
	'	Select Case Mid(a,k,1)
	'		Case "0","1","2","3","4","5","6","7","8","9"
	'			i+=(Asc(a,k)-48)*(16^(Len(a)-k))
	'		Case "a","b","c","d","e","f"
	'			i+=(Asc(a,k)-97+10)*(16^(Len(a)-k))
	'	End Select
	' Next k
            ' function=i

	' let FB do the work, it simple and fast
	Function = ValULng("&h"+a)	' make it a hex number and let ValULng convert it
End Function
version without the comments

Code: Select all

Function from_hex (a As String) As ULongInt
	Dim As UInteger k
	a = LCase(a)
	If Left(a,2)="0x" Then a=Right(a,Len(a)-2)
	If Left(a,2)="&h" Then a=Right(a,Len(a)-2)
	If Right(a,1)="h" Then a=Left(a,Len(a)-1)
	If Len(a)>16 Then a=Right(a,16)
	For k=1 To Len(a)
		Select Case Mid(a,k,1)
			Case_  "0","1","2","3","4","5","6","7","8","9","a","b","c","d","e","f"
			Case Else
				Return 0
		End Select
	Next
	Function = ValULng("&h"+a)
End Function

And since this is the Tips and Tricks section this line

w=ledd+x – maxcol*((ledd+x)\maxcol)

can be changed in

w=(ledd+x) mod maxcol

Regards
TJF
Posts: 3809
Joined: Dec 06, 2009 22:27
Location: N47°, E15°
Contact:

Post by TJF »

frisian wrote:And since this is the Tips and Tricks section this line

w=ledd+x – maxcol*((ledd+x)\maxcol)

can be changed in

w=(ledd+x) mod maxcol

Regards
And you'll end up with slower code (MODE is much slower than integer operations.)

Better change to

Code: Select all

w = ledd + x
w -= maxcol * (w \ maxcol)
Mihail_B
Posts: 273
Joined: Jan 29, 2008 11:20
Location: Romania
Contact:

Post by Mihail_B »

frisian wrote:Mihail_B
...
Regards

Yes sorry ... I never optimezed from_hex(..) function ... anyway I was
using it only for keyboard translation so I said it didn't need any more
work ...

Here's my optimized version ... which is definetly much, much better then then my first :

Code: Select all

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
best regards :)
Last edited by Mihail_B on Oct 15, 2011 7:22, edited 1 time in total.
Mihail_B
Posts: 273
Joined: Jan 29, 2008 11:20
Location: Romania
Contact:

Post by Mihail_B »

frisian wrote: Regards
I've made a speed test between using :
- 1) from_hex with my new optimized version
- 2) from_hexf using VALULNG
- 3) and direct VALULNG ....
- 4) and my fastest way
- 5) and my fastest way with out prefix "&h"

Code: Select all

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_hexfast (a as string) as ULongInt
 dim as ulongint i
 dim as UByte k
 Dim As UByte bu1,bu2,l,bu3
 Dim As UByte c
 bu2=97-10
 bu3=65-10
 i=0
 k=1:l=Len(a)
 If Asc(a,1)=Asc("&") Then k+=2
 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
    ElseIf bu1>=65 AndAlso bu1<=70 Then
      bu1-=bu3
    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_hexf (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
 
 Function=ValULng("&h"+a)
End Function

Sub pause1 overload()
   Dim As String a
   a=InKey:While a="":Sleep 100:a=InKey:wend
End Sub
Sub pause1(a As String)
   Print a
   a=InKey:While a="":Sleep 100:a=InKey:wend
End Sub

Sub rdtsc1(i as ulongint ptr)
	Asm
        push eax
        push edx
        push ecx
        rdtsc
        mov ecx,[i]
        mov [ecx],eax
        mov [ecx+4],edx
        pop ecx
        pop edx
        pop eax
	End asm
end Sub

Dim i As Integer
Dim As ULongInt t
For i=0 To 111111
   If from_hex("0x"+Hex(i))<>i Then 
      Print "0x"+Hex(i);",";from_hex("0x"+Hex(i));",";i 
      Beep
      pause1
   EndIf
Next i
pause1  "done with validity test; press any key to start speed test ..."
Print "gooo !"
Dim As ULongInt t1,t2,x1,x2,uf1,uf2,fa1,fa2,fo1,fo2
rdtsc1 @x1
For i=0 To 1111111
   t=from_hexf("0x"+Hex(i))
Next i
rdtsc1 @x2
rdtsc1 @t1
For i=0 To 1111111
   t=from_hex("0x"+Hex(i))
Next i
rdtsc1 @t2
rdtsc1 @uf1
For i=0 To 1111111
   t=valulng("&h"+Hex(i))
Next i
rdtsc1 @uf2

rdtsc1 @fa1
For i=0 To 1111111
   t=from_hexfast("&h"+Hex(i))
Next i
rdtsc1 @fa2

rdtsc1 @fo1
For i=0 To 1111111
   t=from_hexfast(Hex(i))
Next i
rdtsc1 @fo2


Print
Print "from_hex(zdupy)        ";(t2-t1)
Print "from_hex(uses valulng) ";(x2-x1)
Print "direct valulng         ";(uf2-uf1)
Print "my fastest way         ";(fa2-fa1)
Print "my even fastest way    ";(fo2-fo1)
Print " ? :" ;
If (x2-x1)>(t2-t1) Then 
   Print "form_hex(zdupy) faster then from_hexf(uses valulng)"
   Print (x2-x1)-(t2-t1) 
Else 
   Print "from_hexf(uses valulng) faster then from_hex(zdupy)"
   Print (t2-t1)-(x2-x1)
EndIf
If (fa2-Fa1)>(uf2-uf1) Then
   Print "valulng is faster then my fastest way"
   Print (fa2-Fa1)-(uf2-uf1)
Else 
   Print "my fastest way is faster then valulng"
   Print (uf2-uf1)-(fa2-Fa1) 
EndIf

Beep
pause1 "[test complete]"
-i've edited this post several times ... :)
frisian
Posts: 249
Joined: Oct 08, 2009 17:25

Post by frisian »

TJF

I disagree about your claim that MOD is slower than your way.

Simple program to see how FB compile the program into assembler code.

Code: Select all

' save as testmod.bas
Dim As Integer q, q1 = 335 ,q2 = 113 

Asm			' helps to find the code in the .asm file 
	nop          ' code produced by FB contains 
	nop          ' most of the time no [b]nop[/b]
End Asm

' mod
q = q1 Mod q2

Asm 
	nop
	nop
End Asm

' TJF's method

q = q1 - q2*(q1\q2)

Asm 
	nop
	nop
End Asm
To get the assembler listing do: fbc -s console -R testmod.bas
this wil give the following testmod.asm listing

Code: Select all

	.intel_syntax noprefix

	#testmod.bas' compilation started at 16:32:19 (FreeBASIC 0.22.0)

.section .text
.balign 16

.globl _main
_main:
push ebp
mov ebp, esp
and esp, 0xFFFFFFF0
sub esp, 16
push ebx
push esi
push edi
mov dword ptr [ebp-4], 0
call ___main
push 0
push dword ptr [ebp+12]
push dword ptr [ebp+8]
call _fb_Init@12
.Lt_0002:
mov dword ptr [ebp-8], 0
mov dword ptr [ebp-12], 335
mov dword ptr [ebp-16], 113
nop                                               <== first pair of nop's
nop                                               <== mod routine follows			

									
mov eax, dword ptr [ebp-12]
cdq
idiv dword ptr [ebp-16]
mov eax, edx
mov dword ptr [ebp-8], eax
nop                                               <== second pair of nop's
nop                                               <== TJF method follows
mov eax, dword ptr [ebp-12]
cdq
idiv dword ptr [ebp-16]
imul eax, dword ptr [ebp-16]
mov ebx, dword ptr [ebp-12]
sub ebx, eax
mov dword ptr [ebp-8], ebx
nop												

<== third pair of nop's					
nop												

<== end
.Lt_0003:
push 0
call _fb_End@4
mov eax, dword ptr [ebp-4]
pop edi
pop esi
pop ebx
mov esp, ebp
pop ebp
ret
	#testmod.bas' compilation took 0.0001762614615043456 secs
Find and remove the part we are interested in.

using Mod
q = q1 Mod q2

mov eax, dword ptr [ebp-12]
cdq
idiv dword ptr [ebp-16]
mov eax, edx
mov dword ptr [ebp-8], eax


TJF's method
q = q1 - q2*(q1\q2)

mov eax, dword ptr [ebp-12]
cdq
idiv dword ptr [ebp-16]
imul eax, dword ptr [ebp-16]
mov ebx, dword ptr [ebp-12]
sub ebx, eax
mov dword ptr [ebp-8], ebx

After removing identical lines we are left with
  • using mod
    mov eax, edx
    mov dword ptr [ebp-8], eax

    TJF's method
    imul eax, dword ptr [ebp-16]
    mov ebx, dword ptr [ebp-12]
    sub ebx, eax
    mov dword ptr [ebp-8], ebx
Since eax and ebx are both 32 bit registers we can remove those lines.
Lets say that mov eax, edx and mov ebx, dword ptr [ebp-12] are identical we can also remove those lines.
(Technical they are not equal, they are a 32 bit register and a value stored in 32 bits of memory ).

That leave us with
  • using mod

    TJF's method
    imul eax, dword ptr [ebp-16]
    sub ebx, eax
TJF's method has 2 instructions left so it highly unlikely that this method faster is then MOD
(The MOD routine is also shorter)


Mihail_B

The function's from_hex and from_hexfast return the wrong value if the input number is to big
To see this attach the following lines to the listing in your last posting.

Code: Select all

i=2^48-1
Print "2^40-1 is in Dec="; i;" and in hex=";Hex(i)
Print "direct           "; ValULng("&h"+Hex(i))
t=from_hex("&h"+Hex(i))
Print "from_hex         ";t
t=from_hexfast("&h"+Hex(i))
Print "from_hexfast     ";t
Sleep
The problem is the line: i Or=(bu1 Shl c) (in both functions)
the temporary storage is 32bits, it should be 64bits.
To force 64bits make bu1 or c 64bits.
the best choice would be make c a ULngint.
Mihail_B
Posts: 273
Joined: Jan 29, 2008 11:20
Location: Romania
Contact:

Post by Mihail_B »

frisian wrote:TJF
I disagree about your claim that MOD is slower than your way.
...
To force 64bits make bu1 or c 64bits.
the best choice would be make c a ULngint.
The fastest way is to use most of the time powers of two :D

and instead of
(i mod k)
do
(i and (k-1))
:D

---
that's my bug ... ! you are right I sould've use a 64bit for bu1 || c ...

thanks for reply ... i'm boring ... here ... :)
TJF
Posts: 3809
Joined: Dec 06, 2009 22:27
Location: N47°, E15°
Contact:

Post by TJF »

@friasian

Thanks for checking the ASM code. My version looks much slower than the MOD version. But when I check it using MichaelWs cycle timer I get
q = q1 MOD q2: 46 cycles
q = q1 - q2 * (q1 \ q2): 49 cycles
So, indeed you're right, the MOD variant is a bit faster.

But since you mostly need the remainder of the division (Modulus) and the result of the integer division as well (see next line t=y+(x+ledd)\maxcol), it's faster to code it my way and to re-use the intermediate results.
Post Reply