'uses corewin
uses console
' oxygen basic, simple example for schroedinger's cat experiment
' about physic and quantenmechanic, by frank bruebach, 25-09-2024
'
extern lib "kernel32.dll"
! GetTickCount
! GetTickCount64
end extern
int seed=0x12345678
'
function Rnd() as float
=======================
'
Static As float f, d=1/0x7fffffff
mov eax,seed
inc eax
rol eax,13
xor eax,0xdab5ca3a
mov seed,eax
push eax
fild dword [esp]
pop eax
fmul dword d
fstp dword f
return f
end function
int i,a
string s
'Randomize TIMER
int seed=gettickcount()
Print "Quantum Condition Simulation"
Print "-----------------------------"
Print "Press any key to observe the condition..."
Do
cls
Print "Observing the condition..."
FOR i = 1 TO 5
Print "."
SLEEP 500
NEXT i
IF Rnd() > 0.5 THEN
Print "The condition is True."
ELSE
Print "The condition is False."
END IF
Print "Press any key to observe again or 'Q' to exit."
a=getkey
s=lcase Chr(a)
if s="q" then
exit do
end if
loop until inkey = CHR(27)
print "press key to continue or q to exit"
cls
End
wait
'=========================================================================================================
Function ControlFont ( byval hwnd as long,byval height As Long, byval width As long, byval flag As Long,byval fontname As string)
int hFont
hFont = CreateFont( height,width,0,0,flag,0,0,0,1,0,0,0,2,fontname)
'CreateFont(_fsize,0,0,0,_ff,_fi,_fu,_fs,1,0,0,0,2,_fname)
SendMessage hwnd,WM_SETFONT,hfont,1
End Function
' cube and collision example, july-august 2024, frank bruebach
' 10-august-2024, oxygen Basic
'
' the collision works fine here -> both cubes lays upon each other
' move cube with arrows up,down,left,right
'
'includepath "$\inc\"
$ FileName "t.exe"
$ title "cubes and collision simple"
$ fontA = "Arial",FW_SEMIBOLD
int width=640
int height=480
uses OpenglSceneFrame
indexbase 1
Type BoundingBox
minX As Single
maxX As Single
minY As Single
maxY As Single
minZ As Single
maxZ As Single
End Type
Dim cube1 As BoundingBox
Dim cube2 As BoundingBox
Dim cube1Pos As Single = 2
Dim cube2Pos As Single = -2
Dim cube1PosX As Single = 2
Dim cube1PosY As Single = -2
Dim cube2PosX As Single = 2
Dim cube2PosY As Single = -2
Function CheckCollision(ByRef box1 As BoundingBox, ByRef box2 As BoundingBox) As LONG
' Check if the bounding boxes overlap in the X dimension
If box1.maxX < box2.minX Or box1.minX > box2.maxX Then
Return False
End If
' Check if the bounding boxes overlap in the Y dimension
If box1.maxY < box2.minY Or box1.minY > box2.maxY Then
Return False
End If
' Check if the bounding boxes overlap in the Z dimension
If box1.maxZ < box2.minZ Or box1.minZ > box2.maxZ Then
Return False
End If
' If all dimensions overlap, there is a collision
Return True
End Function
sub Initialize(sys hWnd)
'=======================
end sub
'
'----------------------------------------------------------------------------------- //
sub DrawGlCube(ByRef rotangle As Single, ByVal posX As Single, ByVal posY As Single)
glLoadIdentity
'glTranslatef 1.5, 0.0, -6.0
glTranslatef(posX, posY, -7)
'glRotatef ang1,1.0, 1.0, 1.0 'rquad
glBegin GL_QUADS
glColor3f 0.0, 1.0, 0.0
glVertex3f 1.0, 1.0, -1.0
glVertex3f -1.0, 1.0, -1.0
glVertex3f -1.0, 1.0, 1.0
glVertex3f 1.0, 1.0, 1.0
glColor3f 1.0, 0.5, 0.0
glVertex3f 1.0, -1.0, 1.0
glVertex3f -1.0, -1.0, 1.0
glVertex3f -1.0, -1.0, -1.0
glVertex3f 1.0, -1.0, -1.0
glColor3f 1.0, 0.0, 0.0
glVertex3f 1.0, 1.0, 1.0
glVertex3f -1.0, 1.0, 1.0
glVertex3f -1.0, -1.0, 1.0
glVertex3f 1.0, -1.0, 1.0
glColor3f 1.0, 1.0, 0.0
glVertex3f 1.0, -1.0, -1.0
glVertex3f -1.0, -1.0, -1.0
glVertex3f -1.0, 1.0, -1.0
glVertex3f 1.0, 1.0, -1.0
glColor3f 0.0, 0.0, 1.0
glVertex3f -1.0, 1.0, 1.0
glVertex3f -1.0, 1.0, -1.0
glVertex3f -1.0, -1.0, -1.0
glVertex3f -1.0, -1.0, 1.0
glColor3f 1.0, 0.0, 1.0
glVertex3f 1.0, 1.0, -1.0
glVertex3f 1.0, 1.0, 1.0
glVertex3f 1.0, -1.0, 1.0
glVertex3f 1.0, -1.0, -1.0
glEnd
End sub
'----------------------------------------------------------------------------------- //
sub DrawGlCube2(ByRef rotangle As Single, ByVal posX As Single, ByVal posY As Single)
glLoadIdentity
'glTranslatef -1.5, 0.0, -7.0
'glRotatef ang1,1.0, 1.0, 1.0 'rquad
glTranslatef(posX, posY, -7)
glBegin GL_QUADS
glColor3f 0.0, 1.0, 0.0
glVertex3f 1.0, 1.0, -1.0
glVertex3f -1.0, 1.0, -1.0
glVertex3f -1.0, 1.0, 1.0
glVertex3f 1.0, 1.0, 1.0
glColor3f 1.0, 0.5, 0.0
glVertex3f 1.0, -1.0, 1.0
glVertex3f -1.0, -1.0, 1.0
glVertex3f -1.0, -1.0, -1.0
glVertex3f 1.0, -1.0, -1.0
glColor3f 1.0, 0.0, 0.0
glVertex3f 1.0, 1.0, 1.0
glVertex3f -1.0, 1.0, 1.0
glVertex3f -1.0, -1.0, 1.0
glVertex3f 1.0, -1.0, 1.0
glColor3f 1.0, 1.0, 0.0
glVertex3f 1.0, -1.0, -1.0
glVertex3f -1.0, -1.0, -1.0
glVertex3f -1.0, 1.0, -1.0
glVertex3f 1.0, 1.0, -1.0
glColor3f 0.0, 0.0, 1.0
glVertex3f -1.0, 1.0, 1.0
glVertex3f -1.0, 1.0, -1.0
glVertex3f -1.0, -1.0, -1.0
glVertex3f -1.0, -1.0, 1.0
glColor3f 1.0, 0.0, 1.0
glVertex3f 1.0, 1.0, -1.0
glVertex3f 1.0, 1.0, 1.0
glVertex3f 1.0, -1.0, 1.0
glVertex3f 1.0, -1.0, -1.0
glEnd
end sub
'------------------ //
sub Scene(sys hWnd)
'==================
'
static single ang1,angi1=1
static Single angle
static int fps
'
glClearColor 0.3, 0.3, 0.5, 0
glClear GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT
'
glLoadIdentity
'
glClearColor 0.5, 0, 0, 0
glPushMatrix
'
glLoadIdentity
static int framecount
sys x,y
framecount++
gltranslatef -.5,.25,-4.0
glColor3f .99,.50,.50
glscalef .2,.2,.01 ''*** larger scale from ,06
gprint str(framecount)
'
glpopmatrix
'
glLoadIdentity
glpushMatrix
gltranslatef 2.0, 0.0, -4.0
'glClearColor 0.8, 0.3, 0.5, 0
glscalef .2,.2,.01
glRotatef 90.0,0,0,1
gprint "Hello openGL"
glPopMatrix
'
if not key[16] 'shift'
if key[37] then cube1PosX -= 0.1 ' to right side
if key[39] then cube1PosX += 0.1 ''
if key[38] then cube1PosY += 0.1 '' up ''
if key[40] then cube1PosY -= 0.1 '' down ''
if key[33] then cube1PosY += 0.1 '''page up
if key[34] then cube1PosY -= 0.1 '''page down
end if
' Update bounding boxes
cube1.minX = cube1PosX - 1
cube1.maxX = cube1PosX + 1
cube1.minY = cube1PosY - 1
cube1.maxY = cube1PosY + 1
cube1.minZ = -7 - 1
cube1.maxZ = -7 + 1
cube2.minX = cube2PosX - 1
cube2.maxX = cube2PosX + 1
cube2.minY = cube2PosY - 1
cube2.maxY = cube2PosY + 1
cube2.minZ = -7 - 1
cube2.maxZ = -7 + 1
' Clear the screen
glClear(GL_COLOR_BUFFER_BIT)
' Draw the cubes
'glEnable(GL_CULL_FACE)
DrawGlCube(angle, cube1PosX, cube1PosY)
DrawGlCube2(angle, cube2PosX, cube2PosY)
'glDisable(GL_CULL_FACE)
'------------------------------- // solved and corrected ----------- //
' Check for collision
'If not CheckCollision(cube1, cube2) Then
If CheckCollision(cube1, cube2) Then
gltranslatef 4.0, 0.0, -4.0
glscalef .52,.52,.01
glRotatef 90.0,0,0,1
gprint "Collision!"
End If
'------------------------------- // solved and corrected ----------- //
'ang1+=angi1
if ang1>360 then ang1-=360
end sub
sub Release(sys hwnd)
'====================
end sub
' create fonts in winapi without gdiplus
' GUI winapi, sdk style
'
$ filename "CreateFonts.exe"
'uses rtl32
'uses rtl64
uses winutil
% OUT_DEFAULT_PRECIS = 0
% OUT_OUTLINE_PRECIS = 8
macro RGB(r,g,b) {r+(g<<8)+(b<<16)}
sub setfontcolours(f As sys,text As long,background As long=0)
SetTextColor(f,text)
if background=0 then
SetBkMode(f,TRANSPARENT)
else
SetBkColor(f,background)
end if
end sub
sub setfontsize(f As sys,size As Long,style As string,weight as long=400)
SelectObject(f,CreateFont(size,0,0,0,weight,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,style))
end sub
sys hInstance=inst
MainWindow 720,500
'------------------------------------------------------------------ //
function WndProc ( sys hWnd, wMsg, wParam, lparam ) as sys callback
dim as rect crect
static as sys hdc
static as String txt
static as PaintStruct Paintst
sys hfont
sys hInstances
hfont = CreateFont(50, 50, 0, 0, _ ' --> here you can change font size, 40, 40
FW_NORMAL, FALSE, TRUE, FALSE,_
ANSI_CHARSET, OUT_DEFAULT_PRECIS,_
CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,_
DEFAULT_PITCH or FF_ROMAN,_
"Comic")
select wMsg
case WM_CREATE
SetWindowText(hwnd, "OxygenBASIC")
GetClientRect hWnd,&cRect
Dim As RECT rc
GetClientRect(hWnd, @rc)
' Create Editbox
sys hwndEdit = CreateWindowEx(0, "EDIT", "size fonts", _
WS_CHILD Or WS_BORDER Or WS_VISIBLE Or ES_AUTOHSCROLL Or ES_MULTILINE, _
20, 220, 640, 180, _
hWnd, 0, hInstances,ByVal 0)
SendMessage(hwndEdit, WM_SETFONT, hfont, TRUE)
case WM_DESTROY
PostQuitMessage 0
case WM_PAINT
GetClientRect hWnd,&cRect
hDC=BeginPaint hWnd,&Paintst
setfontsize(hdc,80,"times new roman")
setfontcolours(hdc,rgb(0,200,0))
SetBkColor hdc,yellow
SetTextColor hdc,red
TextOut hDC, 50, 80, "Hello, OxygenBasic!", 20' 25
setfontcolours(hdc,rgb(100,200,200))
TextOut hDC, 40, 20, "Hello, Batman!", 15
EndPaint hWnd,&Paintst
case WM_KEYDOWN
Select wParam
Case 27 : SendMessage hwnd, WM_CLOSE, 0, 0
End Select
case else
function=DefWindowProc hWnd,wMsg,wParam,lParam
end select
end function
' how to create fonts in winapi without gdiplus
' halProment: new-> fontsize and color, 20-09-2024, frank bruebach
' GUI winapi, sdk style
'
uses promgui
#foreward
%OUT_DEFAULT_PRECIS = 0?
%ANSI_CHARSET = 0?
%DEFAULT_CHARSET = 1?
%SYMBOL_CHARSET = 2?
%CLIP_DEFAULT_PRECIS = 0?
%CLIP_CHARACTER_PRECIS = 1?
%DEFAULT_QUALITY = 0?
%DEFAULT_PITCH = 0?
%FIXED_PITCH = 1?
%VARIABLE_PITCH = 2?
%MONO_FONT = 8?
%FF_DONTCARE = 0?
%FF_ROMAN = 16?
%FF_SWISS = 32?
%OUT_OUTLINE_PRECIS = 8?
DECLARE FUNCTION SetBkMode LIB "GDI32.DLL" ALIAS "SetBkMode" ( _
BYVAL hdc AS DWORD _
, BYVAL mode AS LONG _
) AS LONG
DECLARE FUNCTION CreateFontA LIB "GDI32.DLL" ALIAS "CreateFontA" ( _
BYVAL cHeight AS LONG _
, BYVAL cWidth AS LONG _
, BYVAL cEscapement AS LONG _
, BYVAL cOrientation AS LONG _
, BYVAL cWeight AS LONG _
, BYVAL bItalic AS DWORD _
, BYVAL bUnderline AS DWORD _
, BYVAL bStrikeOut AS DWORD _
, BYVAL iCharSet AS DWORD _
, BYVAL iOutPrecision AS DWORD _
, BYVAL iClipPrecision AS DWORD _
, BYVAL iQuality AS DWORD _
, BYVAL iPitchAndFamily AS DWORD _
, OPTIONAL BYREF pszFaceName AS STRING _ ''ASCIIZ _
) AS DWORD
function rgb(sys red,green,blue) as pro
sys color
color = red
color = color + green*256
color = color + blue*65536
return color
end function
'---------------------------------------- //
dim cmdline as asciiz ptr, inst as sys
@cmdline=GetCommandLine
inst=GetModuleHandle 0
WinMain inst,0,cmdline,SW_NORMAL
end
'-------------------------------------------------------------------- //
Function WinMain(pro inst, prevInst, asciiz*cmdline, pro show) as pro
'==================================================================== //
WndClass wc
MSG wm
pro hwnd, wwd, wht, wtx, wty, tax
with wc
.style = CS_HREDRAW or CS_VREDRAW
.lpfnWndProc = @WndProc
.cbClsExtra =0
.cbWndExtra =0
.hInstance =inst
.hIcon=LoadIcon 0, IDI_APPLICATION
.hCursor=LoadCursor 0,IDC_ARROW
.hbrBackground = GetStockObject WHITE_BRUSH
.lpszMenuName =null
.lpszClassName = strptr "Demo"
end with
RegisterClass (@wc)
Wwd = 720 : Wht = 500
Tax = GetSystemMetrics SM_CXSCREEN
Wtx = (Tax - Wwd) /2
Tax = GetSystemMetrics SM_CYSCREEN
Wty = (Tax - Wht) /2
hwnd = CreateWindowEx 0,wc.lpszClassName,"halProment BASIC",WS_OVERLAPPEDWINDOW,Wtx,Wty,Wwd,Wht,0,0,inst,0
ShowWindow hwnd,SW_SHOW
UpdateWindow hwnd
'
pro bRet
'
do while bRet := GetMessage (@wm, 0, 0, 0)
if bRet = -1 then
'show an error message
else
TranslateMessage @wm
DispatchMessage @wm
end if
wend
End Function
Sub setfontcolours(f As pro,text As long,background As long=0)
SetTextColor(f,text)
if background=0 then
SetBkMode(f,TRANSPARENT)
else
SetBkColor(f,background)
end if
End Sub
Sub setfontsize(f As pro,size As Long,style As string,weight as long=400)
SelectObject(f,CreateFont(size,0,0,0,weight,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,style))
End Sub
'------------------------------------------------------------------ //
function WndProc ( pro hWnd, wMsg, wParam, lparam ) as pro callback
'================================================================== //
dim as rect crect
static as pro hdc
static as String txt
static as PaintStruct Paintst
pro hfont
pro hInstances
hfont = CreateFont(50, 50, 0, 0, _ ' --> here you can change font size, 40, 40
FW_NORMAL, FALSE, TRUE, FALSE,_
ANSI_CHARSET, OUT_DEFAULT_PRECIS,_
CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,_
DEFAULT_PITCH or FF_ROMAN,_
"Comic")
select wMsg
case WM_CREATE
// ----------- //
GetClientRect hWnd,&cRect
Dim As RECT rc
GetClientRect(hWnd, @rc)
' Create Editbox
pro hwndEdit = CreateWindowEx(0, "EDIT", "size fonts", _
WS_CHILD Or WS_BORDER Or WS_VISIBLE Or ES_AUTOHSCROLL Or ES_MULTILINE, _
20, 220, 640, 180, _
hWnd, 0, hInstances,ByVal 0)
SendMessage(hwndEdit, WM_SETFONT, hfont, TRUE)
case WM_DESTROY
// ----------- //
PostQuitMessage 0
case WM_PAINT
// ----------- //
GetClientRect hWnd,&cRect
hDC=BeginPaint hWnd,&Paintst
setfontsize(hdc,80,"times new roman")
setfontcolours(hdc,rgb(0,200,0))
SetBkColor hdc,yellow
SetTextColor hdc,red
'DrawText hDC,"Hello World!",-1,&cRect,0x25
TextOut hDC, 50, 80, "Hello, PromentBasic!", 20' 25
setfontcolours(hdc,rgb(100,200,200))
TextOut hDC, 40, 20, "Hello, Batman!", 15
EndPaint hWnd,&Paintst
case WM_KEYDOWN
Select wParam
Case 27 : SendMessage hwnd, WM_CLOSE, 0, 0
End Select
case else
function=DefWindowProc hWnd,wMsg,wParam,lParam
end select
end function
' end of example
Page created in 0.979 seconds with 10 queries.