Compilateur : version de travail disponible

#include"MemoryModule.bi"
#include"incfile.bi"
IncFile(DLLdata,"panoramic.dll")
#lang "fblite"
option gosub
#include once"windows.bi"
dim shared _handl as HWND
dim shared _library as HMEMORYMODULE
_library = MemoryLoadLibrary(DLLdata)
dim shared pc_init as sub stdcall _
(byval operand1 as handle)
pc_init=MemoryGetProcAddress(_library,"pc_init")
dim shared pc_close as sub
pc_close=MemoryGetProcAddress(_library,"pc_close")
DIM SHARED V_X0 AS DOUBLE
DIM SHARED V_Y0 AS DOUBLE
DIM SHARED V_NX AS DOUBLE
DIM SHARED V_NY AS DOUBLE
DIM SHARED V_X AS DOUBLE
DIM SHARED V_Y AS DOUBLE
DIM SHARED V_N AS DOUBLE
DIM SHARED V_XN AS DOUBLE
DIM SHARED V_YN AS DOUBLE
DIM SHARED V_MODUL AS DOUBLE
DIM SHARED V_DX AS DOUBLE
DIM SHARED V_DY AS DOUBLE
DIM SHARED V_L AS DOUBLE
DIM SHARED V_H AS DOUBLE
DIM SHARED V_S AS DOUBLE
DIM SHARED V_TITRE AS STRING
DIM SHARED V_XD AS DOUBLE
DIM SHARED V_YD AS DOUBLE
DIM SHARED V_XA AS DOUBLE
DIM SHARED V_YA AS DOUBLE
dim shared pf_scancode as function stdcall as integer
pf_scancode=MemoryGetProcAddress(_library,"pf_scancode")
dim shared pc_2d_fill_color as sub stdcall _
(byval P1 as integer,_
byval P2 as integer,_
byval P3 as integer)
pc_2d_fill_color=MemoryGetProcAddress(_library,"pc_2d_fill_color")
dim shared pc_2d_pen_color as sub stdcall _
(byval P1 as integer,_
byval P2 as integer,_
byval P3 as integer)
pc_2d_pen_color=MemoryGetProcAddress(_library,"pc_2d_pen_color")
dim shared pc_2d_point as sub stdcall _
(byval P1 as integer,_
byval P2 as integer)
pc_2d_point=MemoryGetProcAddress(_library,"pc_2d_point")
dim shared pc_2d_rectangle as sub stdcall _
(byval P1 as integer,_
byval P2 as integer,_
byval P3 as integer,_
byval P4 as integer)
pc_2d_rectangle=MemoryGetProcAddress(_library,"pc_2d_rectangle")
dim shared pc_caption as sub stdcall _
(byval P1 as integer,_
byval P2 as string)
pc_caption=MemoryGetProcAddress(_library,"pc_caption")
dim shared pc_height as sub stdcall _
(byval P1 as integer,_
byval P2 as integer)
pc_height=MemoryGetProcAddress(_library,"pc_height")
dim shared pc_print_string as sub stdcall _
(byval P1 as string)
pc_print_string=MemoryGetProcAddress(_library,"pc_print_string")
dim shared pc_width as sub stdcall _
(byval P1 as integer,_
byval P2 as integer)
pc_width=MemoryGetProcAddress(_library,"pc_width")
declare function WinMain _
(byval _hInstance as HINSTANCE,_
byval _hPrevInstance as HINSTANCE,_
byval _szCmdLine as string,_
byval _iCmdShow as integer)as integer
end WinMain(GetModuleHandle(null),null,Command(),SW_NORMAL)
function WndProc _
(byval _hWnd as HWND,_
byval _wMsg as UINT,_
byval _wParam as WPARAM,_
byval _lParam as LPARAM)as LRESULT
function=0
select case(_wMsg)
case WM_CREATE
exit function
case WM_DESTROY
pc_close()
sleep 200
MemoryFreeLibrary(_library)
PostQuitMessage(0)
exit function
end select
function=DefWindowProc(_hWnd,_wMsg,_wParam,_lParam)
end function
function WinMain (byval _hInstance as HINSTANCE,_
byval _hPrevInstance as HINSTANCE,_
byval _szCmdLine as string,_
byval _iCmdShow as integer)as integer
dim _wMsg as MSG
dim _wcls as WNDCLASS
dim _hWnd as HWND
function=0
with _wcls
.style=CS_HREDRAW or CS_VREDRAW
.lpfnWndProc=@WndProc
.cbClsExtra=0
.cbWndExtra=0
.hInstance=_hInstance
.hIcon=LoadIcon(NULL,IDI_APPLICATION)
.hCursor=LoadCursor(NULL,IDC_ARROW)
.hbrBackground=GetStockObject(WHITE_BRUSH)
.lpszMenuName=NULL
.lpszClassName=@"HelloWin"
end with
if(RegisterClass(@_wcls)=FALSE)then
MessageBox(null,"Failed to register _wcls","Error",MB_ICONERROR)
exit function
end if
_hWnd = CreateWindowEx(0,_
@"HelloWin",_
"PANORAMIC",_
WS_OVERLAPPEDWINDOW,_
10,_
10,_
200,_
100,_
NULL,_
NULL,_
_hInstance,_
NULL)
_handl=_hWnd
UpdateWindow(_hWnd)
pc_init(_hWnd)
sleep 100
'-------------------------------------------------------------------------------
' SOURCE
'-------------------------------------------------------------------------------
V_L=640
V_H=480
V_S=90
V_TITRE="l'ensemble de JULIA"
pc_width(0,V_L)
pc_height(0,V_H)
pc_caption(0,"Papydall vous présente        "+V_TITRE)
V_XD=V_S
V_YD=V_S
V_XA=V_L-V_S
V_YA=V_H-V_S
pc_2d_pen_color(255,0,0)
pc_2d_fill_color(255,255,0)
pc_2d_rectangle(V_XD,V_YD,V_XA,V_YA)
pc_print_string(" VEUILLEZ PATIENTER ... <ESC> pour arrêter  ")
V_X0=.3
V_Y0=-.5
FOR V_NX=V_XD+V_S TO V_XA-V_S
FOR V_NY=V_YD TO V_YA
V_X=(V_NX-V_L/2)/V_S
V_Y=(V_H/2-V_NY)/V_S
FOR V_N=1 TO 25
pc_2d_pen_color(150+(450-V_NX)/3,V_NY/2,V_N*10)
V_XN=V_X*V_X-V_Y*V_Y+V_X0
V_YN=2*V_X*V_Y+V_Y0
V_DX=V_XN-V_X
V_DY=V_YN-V_Y
V_MODUL=V_XN*V_XN+V_YN*V_YN
V_X=V_XN
V_Y=V_YN
IF V_MODUL>4 THEN
V_N=25
END IF
NEXT V_N
IF V_MODUL<4 THEN
pc_2d_point(V_NX,V_NY)
END IF
IF PF_SCANCODE()=27 THEN
pc_print_string("programme arrête!")
goto _end
END IF
NEXT V_NY
NEXT V_NX
pc_print_string("  TERMINE ")
_end:
while(GetMessage(@_wMsg,NULL,0,0)<>FALSE)
TranslateMessage(@_wMsg)
DispatchMessage(@_wMsg)
wend
function=_wMsg.wParam
end function

'              3D_Mendelbrot.bas
' Interpréteur: 3m31sec = 211 sec
' Compilateur: 2 sec

dim x,y,z,u,v,w,a,b,l,sa,sb,xmax,xmin,ymax,ymin,fin,seuil
dim c$,d$

label test

button 1
caption 1,"OK"
on_click 1,test

c$=time$

caption 0, " <CLICK> pour arrêter"
width 0,700 : height 0,500
xmax = 1.8 : xmin = -2.5 : ymax = 1.8 : ymin = -1.8 : fin = 65 : seuil = 4
2d_fill_color 0,0,255 : 2d_rectangle 0,0,1000,700
for v = 180 to 380
  for u = 380-v to 820-v
    y =(ymax-ymin)*(380-v)/200+ymin
    x =(xmax-xmin)*(u+v-380)/440+xmin
    z = 0 : a = 0 : b = 0 : l = 0
    while (l <= seuil)and(z <= fin)
      z = z + 1 : sa = a : sb = b : a = sa*sa-sb*sb+x : b = 2*sa*sb+y : l = a*a+b*b
    end_while
    w = z*3
    2d_pen_color 255,0,0    : 2d_line u,v,u,v-w
    2d_pen_color 0,0,0      : 2d_line u-2,v,u-2,v-w
    2d_pen_color 255,255,255 : 2d_line u-2,v-w,u,v-w
    ' if scancode <> 0 then terminate
  next u
next v
d$=time$
caption 0,"Début: "+c$+",Fin: "+d$

afficher()

end

test:
  message "OK"
return

sub afficher()
    message "OK"
end_sub

dim boite_dialogue_visible%, false%, form7_creee%, hauteur_boite%, hauteur_ecran%, hnd%, kk%, largeur_boite%, largeur_ecran%, res%, true%, zz99%
false%=0
true%=1
dim sens_traduction$(15)

sens_traduction$(1)="français -> espagnol"
sens_traduction$(2)="espagnol -> français"
sens_traduction$(3)="français -> allemand"
sens_traduction$(4)="allemand -> français"
sens_traduction$(5)="français -> polonais"
sens_traduction$(6)="polonais -> français"
sens_traduction$(7)="français -> anglais"
sens_traduction$(8)="anglais -> français"
sens_traduction$(9)="français -> italien"
sens_traduction$(10)="italien -> français"
sens_traduction$(11)="français -> néerlandais"
sens_traduction$(12)="néerlandais -> français"
sens_traduction$(13)="français -> portugais"
sens_traduction$(14)="portugais -> français"

label valider_dialogue7, valider_sens_traduction

dll_on "kgf.dll"

' Préchargement des drapeaux.
for kk%=1 to 7
    res%=kk%+470
    picture res%
    left res%,-300
    width res%,100
    height res%,70
    stretch_on res%

    ' file_load res%,"images\"+trim$(mid$("espagne        allemagne      pologne        grande_bretagne italie          pays_bas        portugal      ",kk%*16-15,15))+"2.bmp"
next kk%

creer_dialogue7()

dll_off

end

sub creer_dialogue7()

    if form7_creee%=true%
      show 7
          else
      form 7
    end_if

    largeur_ecran%=screen_x
    hauteur_ecran%=screen_y

    largeur_boite%=590
    hauteur_boite%=750

    boite_dialogue_visible%=true%

    ' Cacher les boutons de réduction, agrandissement et fermeture.
    hnd% = handle(7)
    res% = DLL_call2("SetMinimizeMaximize",hnd%,0)
    res% = DLL_call2("SetCloseBox",hnd%,0)

    left 7,(largeur_ecran%-largeur_boite%)/2
    top 7,(hauteur_ecran%-hauteur_boite%)/2
    width 7,largeur_boite%
    height 7,hauteur_boite%

    caption 7,"Choix du sens de traduction."

    for kk%=1 to 14
        res%=kk%+450

        if form7_creee%=false% then option res%
        parent res%,7
        mark_off res%
        caption res%,sens_traduction$(kk%)
        font_size res%,12
        font_bold res%

        if mod(kk%,2)=1
          zz99%=0
          font_color res%,255,0,200
          left res%,20
              else
          zz99%=-45
          font_color res%,45,0,255
          left res%,360
        end_if

        top res%,kk%*45+zz99%
        width res%,200
        height res%,20

        on_click res%,valider_sens_traduction
    next kk%

    if form7_creee%=false%
      for kk%=1 to 7
          res%=kk%+470
          parent res%,7
          left res%,largeur_boite%/2-50
          top res%,kk%*90-70
          width res%,100
          height res%,70
      next kk%

      creer_bouton(478,7,"OK",largeur_boite%/2-50,hauteur_boite%-80,100,30)
      font_size 478,12
      font_bold 478
    end_if

    on_click 478,valider_dialogue7

    form7_creee%=true%

end_sub

valider_sens_traduction:
  ' N° du dernier objet cliqué.
  sens_traduction_texte$=caption$(number_click)
return

valider_dialogue7:
  boite_dialogue_visible%=false%
  hide 7
return

sub creer_bouton(param1%, param2%, param3$, param4%, param5%, param6%, param7%)
    button param1%
    if param2%>0 then parent param1%,param2%
    caption param1%,param3$
    left param1%,param4%
    top param1%,param5%
    width param1%,param6%
    height param1%,param7%
end_sub

 dim titre$
' titre$ = "CECI EST UN TEST" + string$(80," ")+ "Veuillez patienter"
 titre$ = "CECI EST UN TEST" + " Veuillez patienter"
 print titre$

#include"MemoryModule.bi"
#include"incfile.bi"
IncFile(DLLdata,"panoramic.dll")
#lang "fblite"
option gosub
#include once"windows.bi"
dim shared _handl as HWND
dim shared _library as HMEMORYMODULE
_library = MemoryLoadLibrary(DLLdata)
dim shared pc_init as sub stdcall _
(byval operand1 as handle)
pc_init=MemoryGetProcAddress(_library,"pc_init")
dim shared pc_close as sub
pc_close=MemoryGetProcAddress(_library,"pc_close")
DIM SHARED V_TITRE AS STRING
dim shared pc_print_string as sub stdcall _
(byval P1 as string)
pc_print_string=MemoryGetProcAddress(_library,"pc_print_string")
declare function WinMain _
(byval _hInstance as HINSTANCE,_
byval _hPrevInstance as HINSTANCE,_
byval _szCmdLine as string,_
byval _iCmdShow as integer)as integer
end WinMain(GetModuleHandle(null),null,Command(),SW_NORMAL)
function WndProc _
(byval _hWnd as HWND,_
byval _wMsg as UINT,_
byval _wParam as WPARAM,_
byval _lParam as LPARAM)as LRESULT
function=0
select case(_wMsg)
case WM_CREATE
exit function
case WM_DESTROY
pc_close()
sleep 200
MemoryFreeLibrary(_library)
PostQuitMessage(0)
exit function
end select
function=DefWindowProc(_hWnd,_wMsg,_wParam,_lParam)
end function
function WinMain (byval _hInstance as HINSTANCE,_
byval _hPrevInstance as HINSTANCE,_
byval _szCmdLine as string,_
byval _iCmdShow as integer)as integer
dim _wMsg as MSG
dim _wcls as WNDCLASS
dim _hWnd as HWND
function=0
with _wcls
.style=CS_HREDRAW or CS_VREDRAW
.lpfnWndProc=@WndProc
.cbClsExtra=0
.cbWndExtra=0
.hInstance=_hInstance
.hIcon=LoadIcon(NULL,IDI_APPLICATION)
.hCursor=LoadCursor(NULL,IDC_ARROW)
.hbrBackground=GetStockObject(WHITE_BRUSH)
.lpszMenuName=NULL
.lpszClassName=@"HelloWin"
end with
if(RegisterClass(@_wcls)=FALSE)then
MessageBox(null,"Failed to register _wcls","Error",MB_ICONERROR)
exit function
end if
_hWnd = CreateWindowEx(0,_
@"HelloWin",_
"PANORAMIC",_
WS_OVERLAPPEDWINDOW,_
10,_
10,_
200,_
100,_
NULL,_
NULL,_
_hInstance,_
NULL)
_handl=_hWnd
UpdateWindow(_hWnd)
pc_init(_hWnd)
sleep 100
'-------------------------------------------------------------------------------
' SOURCE
'-------------------------------------------------------------------------------
V_TITRE="CECI EST UN TEST"+string$(80," ")+"Veuillez patienter"
V_TITRE="CECI EST UN TEST"+" Veuillez patienter"
pc_print_string(V_TITRE)
_end:
while(GetMessage(@_wMsg,NULL,0,0)<>FALSE)
TranslateMessage(@_wMsg)
DispatchMessage(@_wMsg)
wend
function=_wMsg.wParam
end function

dim i,n
n = 1
for i =  5 to n
   print "hello"
next i
message "terminé"

#include"MemoryModule.bi"
#include"incfile.bi"
IncFile(DLLdata,"panoramic.dll")
#lang "fblite"
option gosub
#include once"windows.bi"
dim shared _handl as HWND
dim shared _library as HMEMORYMODULE
_library = MemoryLoadLibrary(DLLdata)
dim shared pc_init as sub stdcall _
(byval operand1 as handle)
pc_init=MemoryGetProcAddress(_library,"pc_init")
dim shared pc_close as sub
pc_close=MemoryGetProcAddress(_library,"pc_close")
DIM SHARED V_TITRE AS STRING
dim shared pc_print_string as sub stdcall _
(byval P1 as string)
pc_print_string=MemoryGetProcAddress(_library,"pc_print_string")

' ----------- FreeBasic ----------

function Titre(byval i as integer) as string
  dim as string s  
  s = str(i) : if i < 10 then s = " " + s
  s = s + " : CECI EST UN TEST " + string(i, "*")
  s = s + " Veuillez patienter"
  Titre = s
end function

' --------------------------------

declare function WinMain _
(byval _hInstance as HINSTANCE,_
byval _hPrevInstance as HINSTANCE,_
byval _szCmdLine as string,_
byval _iCmdShow as integer)as integer
end WinMain(GetModuleHandle(null),null,Command(),SW_NORMAL)
function WndProc _
(byval _hWnd as HWND,_
byval _wMsg as UINT,_
byval _wParam as WPARAM,_
byval _lParam as LPARAM)as LRESULT
function=0
select case(_wMsg)
case WM_CREATE
exit function
case WM_DESTROY
pc_close()
sleep 200
MemoryFreeLibrary(_library)
PostQuitMessage(0)
exit function
end select
function=DefWindowProc(_hWnd,_wMsg,_wParam,_lParam)
end function
function WinMain (byval _hInstance as HINSTANCE,_
byval _hPrevInstance as HINSTANCE,_
byval _szCmdLine as string,_
byval _iCmdShow as integer)as integer
dim _wMsg as MSG
dim _wcls as WNDCLASS
dim _hWnd as HWND
function=0
with _wcls
.style=CS_HREDRAW or CS_VREDRAW
.lpfnWndProc=@WndProc
.cbClsExtra=0
.cbWndExtra=0
.hInstance=_hInstance
.hIcon=LoadIcon(NULL,IDI_APPLICATION)
.hCursor=LoadCursor(NULL,IDC_ARROW)
.hbrBackground=GetStockObject(WHITE_BRUSH)
.lpszMenuName=NULL
.lpszClassName=@"HelloWin"
end with
if(RegisterClass(@_wcls)=FALSE)then
MessageBox(null,"Failed to register _wcls","Error",MB_ICONERROR)
exit function
end if
_hWnd = CreateWindowEx(0,_
@"HelloWin",_
"PANORAMIC",_
WS_OVERLAPPEDWINDOW,_
10,_
10,_
200,_
100,_
NULL,_
NULL,_
_hInstance,_
NULL)
_handl=_hWnd
UpdateWindow(_hWnd)
pc_init(_hWnd)
sleep 100
'-------------------------------------------------------------------------------
' SOURCE
'-------------------------------------------------------------------------------

' ------------ FreeBasic ------------

for i as integer = 1 to 32
  V_TITRE = Titre(i)
  pc_print_string(V_TITRE)
next i

' -----------------------------------

_end:
while(GetMessage(@_wMsg,NULL,0,0)<>FALSE)
TranslateMessage(@_wMsg)
DispatchMessage(@_wMsg)
wend
function=_wMsg.wParam
end function