' 32 bit and 64 bit example, go, 18-08-2024, fbruebach
' if you want to compile please use: menu: compile/run compiling 64-bit
'
take kons
''32 Bit version x86
pfun Mal(long x,y) as pro
mov eax, [x] 'take x to eax
imul eax, [y] 'multiply with y
mov [function], eax 'result
end function
pro a = 45, b = 54
printl Mal(a, b)
p? Mal(a, b) '2430
printl
printl "push to continue"
wait
printl "test 64-bit"
'' for x86_64 architecture (64-Bit):
' 64 bit version
pfun Mal2(long x,y) as pro
mov rax, [x] ' take x to rax
imul rax, [y] ' multiply with y
mov [pfun], rax 'result
end function
pro a2 = 2123456789, b2 = 2987654321
printl Mal2(a2, b2) '1822673797
p? Mal2(a2, b2)
wait
' ends
Dim variable / suffixes new
' print alternatives and suffixes part one, all examples are running well
' july - august 2024, frank bruebach, halProment,22-08-2024
'
'
dim a as dword
p% a ' p% = dword
a=20
print a
string b
b="Hello tarzan"
p? b ' p?=print alternative
pstring c
c="Hello tarzan2"
p? c
p$ c ' p$=string alternative
c="Hello jane"
p? c
p$ d ' p$=string
d="Hello tarzan3"
p& d ' p&=print alternative
dim e as long
e=2024*365
print e '738760
p% e
e=2024*365
p? e '738760
' ends
Parser example
' -- new parser example, halPromentBasic, march-august2024, frank bruebach
' --
'
take kons
pindex 0
Dim token As String = ""
Dim tokenCount As Integer = 0
ReDim string tokens(tokenCount)
' Split() function
Function Split(string inputs, delimiter, string *tokens(redim) ) As Integer
Dim token As String = ""
Dim tokenCount As Integer = 0
redim string tokens(100)
int i
For i = 1 To Len(inputs)
If Mid(inputs, i, 1) = delimiter Then
If token <> "" Then
tokens(tokenCount) = token
tokenCount += 1
token = ""
End If
Else
token += Mid(inputs, i, 1)
End If
Next
If token <> "" Then
ReDim string tokens(tokenCount)
tokens(tokenCount) = token
End If
Return tokenCount
End Function
' IsNumeric() function
Function IsNumeric(string value ) As Integer
Static string numericChars
numericChars = "0123456789.-"
If Len(value) = 0 Then Return False
int i
int dotCount = 0
For i = 1 To Len(value)
string c = Mid(value, i, 1)
If InStr(numericChars, c) = 0 Then
Return False
ElseIf c = "." Then
dotCount += 1
If dotCount > 1 Then
Return False
End If
End If
Next
Return True
End Function
' EvaluateExpression function
Function EvaluateExpression(string inputs) As Double
Split(inputs," ", tokens())
Dim total As Double = 0
Dim currentNumber As Double = 0
Dim operators As String = "+"
int i
For i = 0 To UBound(tokens)
Dim token As String = tokens(i)
If IsNumeric(token) Then
currentNumber = Val(token)
If operators = "+" Then
total += currentNumber
ElseIf operators = "-" Then
total -= currentNumber
ElseIf operators = "*" Then
total *= currentNumber
ElseIf operators = "/" Then
If currentNumber <> 0 Then
total /= currentNumber
Else
Print "Error: Division by zero"
Exit For
End If
End If
operators = "+"
Else
operators = token
End If
Next
Return total
End Function
' Test my code with different inputs
Dim inputs As String = "2 + 3 * 10" ' 50 result ok
Dim result As Double
result = EvaluateExpression(inputs)
' all tests are running fine here for calculations
' + - * /
' Test my code with different inputs
' Dim inputs As String = "2 + 3 * 10" ' 50 ok
' Dim inputs As String = "5 + 6 + 10" ' 21 ok
' Dim inputs As String = "8 * 5" ' 40 ok
' Dim inputs As String = "20 / 4 " ' 5 ok
' Dim inputs As String = "-20 10" ' -10 ok
' Dim inputs As String = "-10 20" ' ok
Dim inputs As String = "30 -20" ' 10 ok
If result <> 0 Then
Printl "The total is " + result ' result: 50 ok
Else
Printl "Error: Invalid input"
End If
printl result
' Wait for a key press before closing the console
Printl "Press any key to continue..."
wait
' ends
Len Array Print alternatives
' len example and array, july-august2024, f. bruebach
' halProment
'
take kons ' kons = konsole
Dim ps As pstring
ps = "ABCD[2]"
MsgBox Str(Len(ps)) ' 7
printl Str(Len(ps)) ' 7
p$ ps2 ' p$ = string alternative
ps2 = "ABCDE[2]"
MsgBox Str(Len(ps2)) ' 8
p? Str(Len(ps2)) ' 8
Dim st as string
st = "HALPPROM[2]"
MsgBox Str(Len(st)) ' 11
printl Str(Len(st)) ' 11
wait
Load a Textfile and Unicode txt File
A songtext and Chinese characters
' --> loadfile *.txt and unicode, april-august2024
' --> halProment, test version
'
' 1) -------- //
string stunic
loadfile "turnturnturn.txt",stunic ' go with string stunic
print stunic
' 2) -------- //
wstring stunic2
loadfile "chines.txt",stunic2 ' go
print stunic2
Macros Tests new
'' --> macro tests, june-august 2024
''
take kons
'--------------------------------- //print message = p?
macro test1(arg1, arg2 )
p? arg1
p? arg2
if arg2 = ""
p? " 2nd argument not passed"
else
p? arg2
endif
end macro
test1( "1", "2" ) '122
test1( 5, 6 ) '566
'--------------------------------- console output //
macro test2(arg1, arg2 )
printl arg1
printl arg2
if arg2 = ""
printl " 2nd argument not passed"
else
printl arg2
endif
end macro
test2( "1", "2" ) '122
test2( 5, 6 ) '566
macro mult( v1,v2 )
printl v1*v2 ' 8
end macro
mult(2,4)
p? mult(2,4) ' 8
printl "ends"
wait
Parse example new
' new parse example halProment, april-august2024, frank bruebach
'
'
take kons
pindex 1
function Parse(bstring expression, delimiter as string= ",", int index ) as bstring
int count = 1
string temp = ""
int d = 1
int f = 0
int i = 0
string z ""
do
i = instr(d, expression, delimiter)
if i > 0 then
f = i
if count = index then
exit do
end if
count += 1
f += Len(delimiter)
d = f
elseif count = index then
f = Len(expression) + 1
end if
loop until i = 0
return MID(expression,d, f-d)
end function
bstring a,b,c
a = parse("one,two,three", ,2) '' ok -> returns "two"
b = parse("xyz", , 1) ' ok -> returns "xyz"
c = parse("xx1x","x", 3) ' ok -> returns "1"
Printl "'" + a + "'"
Printl "'" + b + "'"
Printl "'" + c + "'"
wait
Powerbasic Looks a Like example new 2
' --> only a test example for powerbasic looks alike, part two
' --> converted to halproment Basic, by frank bruebach, march-july2024
'
#COMPILE_EXE
#DIM_ALL
take poba
FUNCTION PBMAIN () AS LONG
LOCAL a,b,c AS INTEGER
a=2024 : b=365-210 ' circa around for 7 month
c=a*b
FUNCTION=c
MSGBOX 0,"our days counted on earth: " + STR$(c),"PowerBASIC" ,2
'313720 days
END FUNCTION
OpenGL: rotate triangle with Fonts
'
$ sFile "rotating triangle with font.exe"
$ title "Rotating Triangle and rotating Font"
pro width =640
pro height =480
take proglscene
sub Initialize(pro hWnd)
'=======================
end sub
'
sub Scene(pro hWnd)
'==================
'
static single ang1,angi1=1
'
glClearColor 0.3, 0.3, 0.5, 0
glClear GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT
'
glLoadIdentity
glpushMatrix
pro i,j
glLineWidth 2.0
gltranslatef 0,-6.5,-6.0
glBegin GL_LINES
for i = -20 to 20 '-10 to 10
for j = -20 to 20
glVertex3i -20, 0, j
glVertex3i 20, 0, j
glVertex3i i, 0, -20
glVertex3i i, 0, 20
next
next
glEnd
glPopMatrix
glLoadIdentity
'
'
gltranslatef 0.0, 0.0, -4.0
glrotatef ang1, 0.0, 0.0, 1.0
'
glBegin GL_TRIANGLES
glColor3f 1.0, 0.0, 0.0 : glVertex3f 0.0, 1.0, 0.0
glColor3f 0.0, 1.0, 0.0 : glVertex3f -1.0, -1.0, 0.0
glColor3f 0.0, 0.0, 1.0 : glVertex3f 1.0, -1.0, 0.0
glEnd
'
'UPDATE ROTATION ANGLES
'----------------------
glPushMatrix
'
glLoadIdentity
static pro framecount
sys x,y
framecount++
gltranslatef -.5,.25,-4.0
glColor3f .99,.50,.50
glscalef .2,.2,.01
gprint "framecounter: "+str(framecount)
'
glpopmatrix
glpushMatrix
glscalef .2,.2,.01
glRotatef 90.0,0,0,1
gprint "Hello triangle"
glPopMatrix
ang1+=angi1
if ang1>360 then ang1-=360
'
glLoadIdentity
glpushMatrix
gltranslatef 2.0, 0.0, -4.0
glscalef .2,.2,.01
glRotatef 90.0,0,0,1
gprint "Hello openGL"
glPopMatrix
'
end sub
sub Release(sys hwnd)
'====================
end sub
' ends
Load gdip Image
' -- gdip load image from file, adepted gdiplus, oxygen
' -- halProment Basic, 25+27-07-2024, 18-08-2024,frank bruebach
'
take promplus
take promgui
take promImg
'------------------------------
sub GetImages(sys hwnd,sys hdc)
'==============================
long hstatus
long pGraphics,pImage,pBitmap,pStream,pThumbnail
wstring strFileName
long nThumbnailWidth,nThumbnailHeight,nwidth,nheight
'
hStatus = GdipCreateFromHDC hdc, pGraphics
'
' // Create an image and a thumbnail of the image.
'
strFileName = "genuss.jpg" ' take and load an image of your choice
hStatus = GdipLoadImageFromFile strFileName, pImage
hStatus = GdipGetImageThumbnail pImage,70, 50, pThumbnail, null, null
'
' // Draw the original and the thumbnail images.
'
hStatus = GdipGetImageWidth pImage, nWidth
hStatus = GdipGetImageHeight pImage, nHeight
hStatus = GdipGetImageWidth pThumbnail, nThumbnailWidth
hStatus = GdipGetImageHeight pThumbnail, nThumbnailHeight
'
'
'DRAW IMAGES
'
hStatus = GdipDrawImageRect pGraphics, pThumbnail, 10, 10, nThumbnailWidth, nThumbnailHeight
hStatus = GdipDrawImageRectI pGraphics, pImage, 10, 60, nWidth, nHeight
''
' // Cleanup
'
if pThumbnail
GdipDisposeImage pThumbnail
endif
if pImage
GdipDisposeImage pImage
endif
if pBitMap
GdipDisposeImage pBitMap
endif
if pGraphics
GdipDeleteGraphics pGraphics
endif
end sub
long inst,hdc
dim cmdline as asciiz ptr,inst as long
&cmdline=GetCommandLine
inst=GetModuleHandle 0
'--------------------------------------------------------------------------------------------------------------
Function WinMain(byval inst as long,byval prevInst as long,byval cmdline as asciiz, byval show as long) as long
'==============================================================================================================
long hr,hdlg,token
GdiplusStartupInput StartupInput
StartupInput.GdiplusVersion = 1
hr=GdiplusStartup token, StartupInput, byval 0
'
if hr
print "Error initializing GDIplus: " hex hr
exit function
end if
WNDCLASS wc
MSG wm
long hwnd, wwd, wht, wtx, wty, tax
wc.style = CS_HREDRAW or CS_VREDRAW
wc.lpfnWndProc = &WndProc
wc.cbClsExtra =0
wc.cbWndExtra =0
wc.hInstance =inst
wc.hIcon=LoadIcon 0, IDI_APPLICATION
wc.hCursor=LoadCursor 0,IDC_ARROW
wc.hbrBackground = GetStockObject WHITE_BRUSH
wc.lpszMenuName =0
wc.lpszClassName =@"Demo"
RegisterClass (&wc)
Wwd = 600 : Wht = 440
Tax = GetSystemMetrics SM_CXSCREEN
Wtx = (Tax - Wwd) /2
Tax = GetSystemMetrics SM_CYSCREEN
Wty = (Tax - Wht) /2
hwnd = CreateWindowEx 0,wc.lpszClassName,"Image Load Test",WS_OVERLAPPEDWINDOW,Wtx,Wty,Wwd,Wht,0,0,inst,0
ShowWindow hwnd,SW_SHOW
UpdateWindow hwnd
'
bool bRet
'
do while bRet := GetMessage (&wm, 0, 0, 0)
if bRet = -1
'show an error message
exit while
else
TranslateMessage &wm
DispatchMessage &wm
end if
wend
GdiplusShutdown token
End Function
'--------------------------------------------------------------------------------------------------------------------------
function WndProc ( byval hWnd as long, byval wMsg as long, byval wParam as long, byval lparam as long ) as long callback
'==========================================================================================================================
static as Long count=0, refreshes=0, hdc
static as String txt
static as PAINTSTRUCT Paintst
RECT crect
'==========
select wMsg
'==========
'--------------
case WM_CREATE
'=============
''long hTimer = SetTimer (hWnd, IDC_TIMER, 100, &TimerProc)
GetClientRect hWnd,&cRect
'--------------
case WM_TIMER
'=============
'--------------
case WM_DESTROY
'===============
'KillTimer(hWnd,ID_TIMER)
PostQuitMessage 0
'------------
case WM_PAINT
'============
hDC=BeginPaint hWnd,&Paintst
'GetClientRect hWnd,&cRect
'DrawText hDC,"Hello",-1,&cRect,0x25
GetImages hWnd,hDC
'refreshes+=1
EndPaint hWnd,&Paintst
ValidateRect hwnd,&crect
'--------------
case WM_KEYDOWN
'==============
'============
Select wParam
'============
Case 27 : SendMessage hwnd, WM_CLOSE, 0, 0
Case 80
SaveClientImage hwnd
End Select
'
'--------
case else
'========
function=DefWindowProc hWnd,wMsg,wParam,lParam
end select
end function
WinMain inst,0,cmdline,SW_NORMAL
' ends
Three examples are still Missing Here they will follow soon :-)
Here you can find halProment Update August 2024 (Update 6)
Double Buffer gui example
' double buffering gui test, based on example for o2
' halProment Basic, 30-05-2024, 06-06-2024,21-07-2024
'
take promgui
MainWindow 550,450,WS_OVERLAPPEDWINDOW
'-----------------------------------------------------------------------------
% CUSTOM_ID 200
% MARGIN 7
% CELLSIZE 32
% DARKCOLOR RGB(0,80,20)
% LIGHTCOLOR RGB(221,190,0)
type CustomData
pro hwnd
pro style
pro hbrLight
pro hbrDark
end type
'------------------------------------------------------------------------ //
function WndProc(sys hwnd, uint uMsg, pro wParam, lParam) as pro callback
static pro hwndCustom
select uMsg
case WM_CREATE
SetWindowText(hwnd, "Double Buffering Example2")
CustomRegister()
hwndCustom = CreateWindowEx(0,CUSTOM_WC, null, WS_CHILD or WS_VISIBLE or 0,
0, 0, 0, 0, hwnd, CUSTOM_ID, hInstance, null)
if hwndCustom = 0 then mbox "Error: Cannot create hwndCustom"
case WM_SIZE
if wParam = SIZE_MAXIMIZED or wParam = SIZE_RESTORED then
word cx = loword(lParam)
word cy = hiword(lParam)
SetWindowPos(hwndCustom, null, MARGIN, MARGIN,
(cx-2*MARGIN), (cy-2*MARGIN), SWP_NOZORDER)
end if
case WM_CLOSE
DestroyWindow(hwnd)
case WM_DESTROY
PostQuitMessage(0)
case else
return DefWindowProc(hwnd, uMsg, wParam, lParam)
end select
end function
sub CustomPaint(CustomData *pData, pro hDC, RECT *rcDirty, bool bErase)
pro x, y
RECT r
pro hBrush
' Note we paint only the cells overlaping with the dirty rectangle.
for y = (rcDirty.top / CELLSIZE) to (rcDirty.bottom / CELLSIZE)
for x = (rcDirty.left / CELLSIZE) to (rcDirty.right / CELLSIZE)
if mod((x+y),2)=0 then hBrush=pData.hbrLight else hBrush=pData.hbrDark
SetRect(r, x * CELLSIZE, y * CELLSIZE, (x+1) * CELLSIZE, (y+1) * CELLSIZE)
FillRect(hDC, r, hBrush)
next x
next y
end sub
sub CustomDoubleBuffer(CustomData *pData, PAINTSTRUCT *pPaintStruct)
int cx = pPaintStruct.rcPaint.right - pPaintStruct.rcPaint.left
int cy = pPaintStruct.rcPaint.bottom - pPaintStruct.rcPaint.top
pro hMemDC,hBmp,hOldBmp
POINT ptOldOrigin
' Create new bitmap-back device context, large as the dirty rectangle.
hMemDC = CreateCompatibleDC(pPaintStruct.hdc)
hBmp = CreateCompatibleBitmap(pPaintStruct.hdc, cx, cy)
hOldBmp = SelectObject(hMemDC, hBmp)
' Do the painting into the memory bitmap.
OffsetViewportOrgEx(hMemDC, -(pPaintStruct.rcPaint.left),
-(pPaintStruct.rcPaint.top), ptOldOrigin)
CustomPaint(pData, hMemDC, pPaintStruct.rcPaint, true)
SetViewportOrgEx(hMemDC, ptOldOrigin.x, ptOldOrigin.y, null)
' Blit the bitmap into the screen. This is really fast operation and altough
' the CustomPaint() can be complex and slow there will be no flicker any more.
BitBlt(pPaintStruct.hdc, pPaintStruct.rcPaint.left, pPaintStruct.rcPaint.top,
cx, cy, hMemDC, 0, 0, SRCCOPY)
' Clean up.
SelectObject(hMemDC, hOldBmp)
DeleteObject(hBmp)
DeleteDC(hMemDC)
end sub
function CustomProc(pro hwnd, uint uMsg, sys wParam, lParam) as pro callback
CustomData *pData 'Pointer to CustomData structure
if uMsg != WM_CREATE then
&pData=GetWindowLongPtr(hwnd, 0)
end if
select case uMsg
case WM_NCCREATE
pro pdat=getmemory sizeof(CustomData)
if pDat then
SetWindowLongPtr(hwnd, 0, pdat) 'Store the pointer for later use
else
return false
end if
&pData=pdat 'address of pData stucture
pData.hwnd = hwnd
CREATESTRUCT cstr at lParam
pData.style=cstr.style
pData.hbrDark = CreateSolidBrush(DARKCOLOR)
pData.hbrLight = CreateSolidBrush(LIGHTCOLOR)
return true
case WM_ERASEBKGND
return false ' Defer erasing into WM_PAINT
case WM_PAINT
PAINTSTRUCT ps
BeginPaint(hwnd, ps)
' We let application to choose whether to use double buffering
' or not by using the style XXS_DOUBLEBUFFER.
if(pData.style and XXS_DOUBLEBUFFER) then
CustomDoubleBuffer(pData, ps)
else
CustomPaint(pData, ps.hdc, ps.rcPaint, ps.fErase)
end if
EndPaint(hwnd, ps)
return 0
case WM_PRINTCLIENT
RECT rc
GetClientRect(hwnd, rc)
CustomPaint(pData, wParam, rc, true)
return 0
case WM_STYLECHANGED
if wParam = GWL_STYLE then
pData.style = lParam
end if
break
case WM_NCDESTROY
if &pData then
DeleteObject(pData.hbrDark)
DeleteObject(pData.hbrLight)
freememory(&pData)
end if
CustomUnregister()
return 0
end select
return DefWindowProc(hwnd, uMsg, wParam, lParam)
end function
' ends
Listview example with Buttons and combobox
'' testfile for Listview & Colored Button based on example by charles pegge
'' translated to halProment Basic 2024, by frank bruebach, march-july2024
'' 25-07-2024, 28-07-2024.
''
$ sFile "ListviewColoredButtonCombobox.exe"
uses promgui
'--------------------------------------- //
% IDB_BUTTON 1000
sys hWndStdButton
% IDC_OWNERDRAWN 1001
sys hWndClrButton
% IDB_EDIT 2000
sys hWndStdEdit
% IDB_LIST 2001
sys hWndStdList
% IDC_COMBO 2002
sys hWndStdCombo
%CBS_SORT = 256i32
%CBS_DROPDOWN= 2i32
%CBS_SIMPLE= dword 0x0001
MainWindow 640, 620 , WS_OVERLAPPEDWINDOW
'void Combobox_Addstring(hwndctl,lpsz)
function combobox_addstring(byval hwndcombo as dword , byval ltext as bstring ) as string
function=sendMessage(hwndcombo,CB_ADDSTRING, 0, ltext ) 'strptr(ltext)
end function
sub combobox_setcursel(byval hwndcombo as dword , byval index as long )
sendMessage(hwndcombo,CB_SETCURSEL, index,0 )
end sub
function WndProc(sys hwnd, uint MainMsg, sys wParam, lParam) as sys callback
int i,j,countrow,countcol
select case MainMsg
case WM_CREATE
SetWindowText(hwnd, "Listview Editbox Combobox Example Proment")
sys hInstance = GetWindowLongPtr(hWnd, GWL_HINSTANCE)
int Lstyle = WS_CHILD or WS_VISIBLE or LVS_REPORT or WS_TABSTOP or LVS_SHOWSELALWAYS or LVS_SINGLESEL or WS_TABSTOP or _
LVS_REPORT or LVS_SHOWSELALWAYS
int LStyleEx = WS_EX_CLIENTEDGE
hWndStdButton = CreateWindowEx(
0,
"BUTTON",
"Standard Button",
WS_VISIBLE or WS_CHILD,
10, 10,
120, 24,
hWnd,
IDB_BUTTON,
hInstance,
NULL)
hWndClrButton = CreateWindowEx(
0,
"BUTTON",
NULL,
WS_CHILD or BS_OWNERDRAW,
10, 40,
120, 24,
hWnd,
IDC_OWNERDRAWN,
GetWindowLongPtr(hWnd, GWL_HINSTANCE),
NULL)
hWndStdEdit = CreateWindowEx(
0,
"EDIT",
"", ''NULL,
WS_CHILD or WS_VISIBLE or WS_BORDER or ES_AUTOHSCROLL or WS_HSCROLL or WS_VSCROLL OR ES_MULTILINE OR ES_WANTRETURN,
10, 100,
120, 124,
hWnd,
IDB_EDIT,
GetWindowLongPtr(hWnd, GWL_HINSTANCE),
NULL)
' Set an initial text for the textbox
SendMessage(hwndStdEdit, WM_SETTEXT, 0, StrPtr("input text here "))
'
if not hWndClrButton then
MessageBox(NULL, "Button Creation Failed.", "Error", MB_OK or MB_ICONERROR)
return 0
end if
ShowWindow(hWndClrButton, SW_SHOW)
'----------------------> combobox , there are three ways to fill it ------------------- //
hWndStdCombo = CreateWindowEx(
0,
"Combobox",
"", ''NULL,
WS_CHILD or WS_VISIBLE or WS_BORDER or ES_AUTOHSCROLL or WS_HSCROLL or WS_VSCROLL _
OR ES_MULTILINE OR WS_TABSTOP OR CBS_SIMPLE OR CBS_SORT, ''_ '%CBS_DROPDOWNLIST,
10, 230,
120, 124,
hWnd,
IDC_COMBO,
GetWindowLongPtr(hWnd, GWL_HINSTANCE),
NULL)
sys List1=GetDlgItem(hwnd, IDC_Combo)
' // Fill the control with some data
DIM wszText as string
int i
FOR i = 1 TO 9
wszText = "Marvel " + RIGHT("00" + STR(i), 2)
ComboBox_AddString(hWndStdCombo, wszText) '@wszText
NEXT
ComboBox_SetCursel(hWndStdCombo, 0)
'--------------------------------> // listview ------------------------------ //
'
hWndStdList = CreateWindowEx(WS_EX_CLIENTEDGE, "SysListView32", "",lStyle,
140, 10,
420, 460,
hWnd,
IDB_LIST,
GetWindowLongPtr(hWnd, GWL_HINSTANCE),
NULL)
if hWndStdList=null then print "Error: Cannot create Listview"
SendMessage(hWndStdList, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, LVS_EX_FULLROWSELECT or LVS_EX_GRIDLINES)
CountRow=26 : CountCol=6 : LV_COLUMN lvc
for i = 0 to CountCol
Listview_Add_column (hWnd,IDB_LIST, i, "Marvel " + str(i), 110, 0)
next i
for i = 1 to CountRow
Listview_Add_item (hWnd,IDB_LIST, i, 0, "Column 0 Row " + str(i) + " Col 1")
for j = 1 to CountCol
Listview_Set_Item (hWnd,IDB_LIST, i, j, "IronMan " + str(i) + " Thor " + str(j))
next j
next i
'--------------------------------------------- listview ends ---------------------- //
case WM_DRAWITEM
select case wParam
case IDC_OWNERDRAWN
'get the pointer to the item-drawing info
DRAWITEMSTRUCT *ptDrawItem
&ptDrawItem=lParam
' alternative
'DRAWITEMSTRUCT ptDrawItem at lParam
SIZE siz
string text
text = "Color Button"
GetTextExtentPoint32(ptDrawItem.hDC, text, len(text), &siz)
SetTextColor(ptDrawItem.hDC, WHITE)
SetBkColor(ptDrawItem.hDC, RED)
ExtTextOut(ptDrawItem.hDC,
((ptDrawItem.rcItem.right - ptDrawItem.rcItem.left) - siz.cx) \ 2,
((ptDrawItem.rcItem.bottom - ptDrawItem.rcItem.top) - siz.cy) \ 2,
ETO_OPAQUE or ETO_CLIPPED, &ptDrawItem.rcItem, text, len(text), NULL)
uint edge
if ptDrawItem.itemState and ODS_SELECTED then
edge = EDGE_SUNKEN
else
edge = EDGE_RAISED
end if
DrawEdge(ptDrawItem.hDC, &ptDrawItem.rcItem,
edge, BF_RECT)
end select
case WM_COMMAND
select case loword(wParam)
case IDB_BUTTON
select case hiword(wParam)
case BN_CLICKED
MessageBox(NULL, "Selected Standard Button", "Standard Button", MB_OK or MB_ICONINFORMATION)
end select
case IDC_OWNERDRAWN
select case hiword(wParam)
case BN_CLICKED
MessageBox(NULL, "Selected Color Button", "Color Button", MB_OK or MB_ICONINFORMATION)
end select
end select
case WM_CLOSE
DestroyWindow(hWnd)
case WM_DESTROY
PostQuitMessage(0)
case else
return DefWindowProc(hWnd, MainMsg, wParam, lParam)
end select
return 0
end function
' ends
Quad rotate Pyramide OpenGL Scene
' --> openGL scene HalPromentBasic, based on a part of o2 example by charles pegge
' --> march,july,august2024 test example for openGL scene by frank bruebach
'
$ sFile "openGLscene2.exe"
$ title "Rotating Quad Pyramid Scene"
% ExplicitMain '
take proglscene
take opgl2\proshape
take opgl2\protex
take opgl2\promat
take opgl2\propart
pindex 1
pro GdiplusToken
float ang1
float ma[16]
float li[16]
pro cube,sphere
Cloud cloud1
sub RenderPlane(float x,y,z,sc,tex,u,v) ' pro
=======================================
glBindTexture GL_TEXTURE_2D,tex
glPushMatrix
gltranslatef x,y,z
glscalef sc,1,sc
glBegin GL_QUADS
glTexCoord2f 0.0,0.0 : glVertex3f -1.0,0,-1.0
glTexCoord2f u ,0.0 : glVertex3f 1.0,0,-1.0
glTexCoord2f u ,v : glVertex3f 1.0,0, 1.0
glTexCoord2f 0.0,v : glVertex3f -1.0,0, 1.0
glend
glPopMatrix
end sub
sub initialize(pro hWnd)
'=======================
end sub
'
sub scene(pro hWnd)
'==================
'
static single s1,s2,s3,s4,ang1,angi1=1
single rtri, rquad
sphere=CompileList : Spheric 1,1,6 : glEndList
'
glLoadIdentity
glClear GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT
glClearColor 0.5, 0, 0, 0
glShadeModel GL_SMOOTH '' Enable Smooth Shading
'glClearColor 0.0, 0.0, 0.0, 0.5 '' Black Background
glClearDepth 1.0 '' Depth Buffer Setup
glEnable GL_DEPTH_TEST '' Enables Depth Testing
glDepthFunc GL_LEQUAL '' The Type Of Depth Testing To Do
glHint GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST '' Really Nice Perspective Calculations
glEnable GL_LIGHTING
'
pro t1=texn[10]
pro t2=texn[11]
'
'--> SPHERES
glPushMatrix
pindex 1
glTranslatef -20.,10.,-60.0
Material Red
glScalef 6.,6.,6.
glCallList sphere
Material White
glPopMatrix
glPushMatrix
glTranslatef 2.5,-1.0,-6.0
glScalef .5,.5,.5
glCallList sphere
glPopMatrix
'
glEnable GL_TEXTURE_2D
'
'RenderCube 2.5,-2.0,-6.0, 0.5,t1
RenderPlane 0.0,-2.0,-16.0,16.0,t2,8,8
'
glDisable GL_TEXTURE_2D
glDisable GL_LIGHTING
'
s1=.2 'x y
s2=-1 'z
s3=0.5 'color
s4=s3*.2 'color
'
gltranslatef 0,0,-2
glrotatef ang1, 0,0,1
'
glbegin GL_QUADS
glcolor4f 00, s3, s3, 1 : glvertex3f -s1, -s1, s2
glcolor4f s3, s3, 00, 1 : glvertex3f s1, -s1, s2
glcolor4f s4, 0, s3, 1 : glvertex3f s1, s1, s2
glcolor4f s4, 0, s3, 1 : glvertex3f -s1, s1, s2
glend
glLoadIdentity
glTranslatef 1.5, 0.0, -6.0
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
glLoadIdentity
glTranslatef -1.5, 0.0, -6.0
glRotatef ang1,0.0, 1.0, 0.0
glBegin GL_TRIANGLES
glColor3f 1.0, 0.0, 0.0
glVertex3f 0.0, 1.0, 0.0
glColor3f 0.0, 1.0, 0.0
glVertex3f -1.0, -1.0, 1.0
glColor3f 0.0, 0.0, 1.0
glVertex3f 1.0, -1.0, 1.0
glColor3f 1.0, 0.0, 0.0
glVertex3f 0.0, 1.0, 0.0
glColor3f 0.0, 0.0, 1.0
glVertex3f 1.0, -1.0, 1.0
glColor3f 0.0, 1.0, 0.0
glVertex3f 1.0, -1.0, -1.0
glColor3f 1.0, 0.0, 0.0
glVertex3f 0.0, 1.0, 0.0
glColor3f 0.0, 1.0, 0.0
glVertex3f 1.0, -1.0, -1.0
glColor3f 0.0, 0.0, 1.0
glVertex3f -1.0, -1.0, -1.0
glColor3f 1.0, 0.0, 0.0
glVertex3f 0.0, 1.0, 0.0
glColor3f 0.0, 0.0, 1.0
glVertex3f -1.0, -1.0, -1.0
glColor3f 0.0, 1.0, 0.0
glVertex3f -1.0, -1.0, 1.0
glEnd
ang1+=angi1
if ang1>360 then ang1-=360
'
end sub
sub Release(sys hwnd)
'====================
end sub
'------------------------------------------- //
MainWindow width,height,WS_OVERLAPPEDWINDOW
' ends
Last Not least.. I have forgotten my Mandelbrot example (SDK) Modus
' -- halProment: mandelbrot example, julia rings, winmain() sdk style
' -- translation from freebasic code snippets, frank bruebach, 21-02-2024, 25-07-2024
'
$ sfile "testMandelbrot.exe"
take promgui
'const ID_TIMER = 1
%ID_TIMER = 100
dim as integer maxIterations = 1000
dim as double xMin = -2.0, xMax = 1.0, yMin = -1.5, yMax = 1.5
dim as double zoomFactor = 1.0
dim cmdline as asciiz ptr, inst as pro
@cmdline=GetCommandLine
inst=GetModuleHandle 0
DECLARE FUNCTION SetPixel lib "GDI32.DLL" ALIAS "SetPixel" ( _
BYVAL hdc AS DWORD _
, BYVAL x AS LONG _
, BYVAL y AS LONG _
, BYVAL color AS DWORD _
) AS DWORD
DECLARE FUNCTION SetPixelV lib "GDI32.DLL" alias "SetPixelV" ( _
BYVAL hdc AS DWORD _
, BYVAL x AS LONG _
, BYVAL y AS LONG _
, BYVAL color AS DWORD _
) AS LONG
macro RGB(r,g,b) {r+(g<<8)+(b<<16)}
typedef dword COLORREF ' R G B bytes
function RGB(long red,green,blue) as long
Pro color
color = red
color = color + green*256
color = color + blue*65536
return color
end function
function mandelbrot(cReal as double, cImaginary as double, maxIterations as integer) as integer
dim as double zReal = 0.0, zImaginary = 0.0
dim as double temp
dim as integer iteration = 0
while iteration < maxIterations
temp = zReal * zReal - zImaginary * zImaginary + cReal
zImaginary = 2.0 * zReal * zImaginary + cImaginary
zReal = temp
iteration += 1
if (zReal * zReal + zImaginary * zImaginary) > 4.0 then
return iteration
end if
wend
return maxIterations
end function
function juliaRing(cReal as double, cImaginary as double, zReal as double, zImaginary as double, maxIterations as integer) as integer
dim as double temp
dim as integer iteration = 0
while iteration < maxIterations
temp = zReal * zReal - zImaginary * zImaginary + cReal
zImaginary = 2.0 * zReal * zImaginary + cImaginary
zReal = temp
iteration += 1
if (abs(zReal) + abs(zImaginary)) > 2.0 then
return iteration
end if
wend
return maxIterations
end function
sub drawMandelbrotWithJuliaRing(hdc as sys, widths as integer, height as integer, xMin as double, xMax as double, yMin as double, yMax as double, maxIterations as integer)
dim as double x, y, cReal, cImaginary
dim as integer colors, iteration
for x = 0 to widths - 1
for y = 0 to height - 1
cReal = xMin + (xMax - xMin) * x / widths
cImaginary = yMin + (yMax - yMin) * y / height
iteration = mandelbrot(cReal, cImaginary, maxIterations)
' I added here a Julia Ring
iteration = juliaRing(-0.8, 0.156, cReal, cImaginary, maxIterations)
colors = RGB(iteration * 8, iteration * 16, iteration * 32) 'here you can change a lot of things even rnd()
SetPixelV(hdc, x, y, colors)
next y
next x
end sub
'--------------------------------------------------------------------
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 = 900 : Wht = 600
Tax = GetSystemMetrics SM_CXSCREEN
Wtx = (Tax - Wwd) /2
Tax = GetSystemMetrics SM_CYSCREEN
Wty = (Tax - Wht) /2
hwnd = CreateWindowEx 0,wc.lpszClassName,"Mandelbrot JuliaRing SDK Window",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
dim as rect crect
'------------------------------------------------------------------ //
function WndProc ( pro hWnd, wMsg, wParam, lparam ) as pro callback
static as pro hdc
static as String txt
static as PaintStruct Paintst
static as pro initialized = false
select wMsg
case WM_CREATE
sys hdc = GetDC(hwnd)
GetClientRect (hWnd,cRect)
' Set up a timer for animation (optional)
SetTimer(hwnd, ID_TIMER, 500, null) '50, NULL)
initialized = true
ReleaseDC(hwnd, hdc)
case WM_DESTROY
ReleaseDC(hwnd, hdc)
KillTimer(hwnd, ID_TIMER)
PostQuitMessage(0)
case WM_DESTROY
PostQuitMessage 0
case WM_PAINT
GetClientRect hWnd,cRect
hDC=BeginPaint hWnd,Paintst
pro p
if initialized then
p=drawMandelbrotWithJuliaRing(hdc, 900, 700, -2.0, 1.0, -1.5, 1.5, 200)
end if
validateRect(hwnd, null)
EndPaint hWnd,Paintst
case WM_TIMER
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
WinMain inst,0,cmdline,SW_NORMAL
' ends
Gui example: frank's calculator
' -- halProment-> franks calculator
' -- 23.03.2024, 22.08.2024, translated of my own freebasic example ;)
'
'
take promgui
% IDB_BUTTON 100
sys hWndStdButton
% IDC_OWNERDRAWN 1000
sys hWndClrButton
% IDC_TRANSLATE 1001
sys hWndClrButton2
% IDC_EDIT 1002
sys myEdit
% IDC_EDIT2 1003
sys myEdit2
MainWindow 440, 320 , WS_OVERLAPPEDWINDOW
' Constants for controls
% IDC_NUM1 = 1001
% IDC_NUM2 = 1002
% IDC_RESULT = 1003
% IDC_ADD = 2001
% IDC_SUBTRACT = 2002
% IDC_MULTIPLY = 2003
% IDC_DIVIDE = 2004
% IDC_CALCULATE = 2005
Function WndProc(pro hwnd, uint MainMsg, pro wParam, lParam) as pro callback
select case MainMsg
case WM_CREATE
SetWindowText(hwnd, "frank's Translator")
sys hInstance = GetWindowLongPtr(hWnd, GWL_HINSTANCE)
' Create edit boxes for numbers
CreateWindowEx(0, "EDIT", "", WS_CHILD Or WS_VISIBLE Or WS_BORDER Or ES_MULTILINE Or ES_AUTOHSCROLL, 50, 50, 100, 20, hWnd, IDC_NUM1, GetModuleHandle(Null), ByVal Null)
CreateWindowEx(0, "EDIT", "", WS_CHILD Or WS_VISIBLE Or WS_BORDER Or ES_MULTILINE Or ES_AUTOHSCROLL, 200, 50, 100, 20, hWnd, IDC_NUM2, GetModuleHandle(Null), ByVal Null)
' Create radio buttons for operations
CreateWindowEx(0, "BUTTON", "+", WS_CHILD Or WS_VISIBLE Or BS_AUTORADIOBUTTON, 50, 100, 50, 20, hWnd, IDC_ADD, GetModuleHandle(Null), ByVal Null)
CreateWindowEx(0, "BUTTON", "-", WS_CHILD Or WS_VISIBLE Or BS_AUTORADIOBUTTON, 100, 100, 50, 20, hWnd, IDC_SUBTRACT, GetModuleHandle(Null), ByVal Null)
CreateWindowEx(0, "BUTTON", "*", WS_CHILD Or WS_VISIBLE Or BS_AUTORADIOBUTTON, 150, 100, 50, 20, hWnd, IDC_MULTIPLY, GetModuleHandle(Null), ByVal Null)
CreateWindowEx(0, "BUTTON", "/", WS_CHILD Or WS_VISIBLE Or BS_AUTORADIOBUTTON, 200, 100, 50, 20, hWnd, IDC_DIVIDE, GetModuleHandle(Null), ByVal Null)
' Create button for calculation
CreateWindowEx(0, "BUTTON", "=", WS_CHILD Or WS_VISIBLE Or BS_AUTORADIOBUTTON, 250, 100, 50, 20, hWnd, IDC_CALCULATE, GetModuleHandle(Null), ByVal Null)
' Create edit box for result
CreateWindowEx(0, "EDIT", "", WS_CHILD Or WS_VISIBLE Or WS_BORDER Or ES_MULTILINE Or ES_AUTOHSCROLL Or ES_READONLY, 50, 150, 250, 20, hWnd, IDC_RESULT, GetModuleHandle(Null), ByVal Null)
' Set default operation to addition
SendDlgItemMessage(hWnd, IDC_ADD, BM_SETCHECK, BST_CHECKED, 0)
Case WM_COMMAND
If HIWORD(wParam) = BN_CLICKED Then
dim operation As String
' Get selected operation
Select Case LOWORD(wParam)
Case IDC_ADD
operation = "+"
Case IDC_SUBTRACT
operation = "-"
Case IDC_MULTIPLY
operation = "*"
Case IDC_DIVIDE
operation = "/"
Case IDC_CALCULATE
Dim num1 As Double
Dim num2 As Double
Dim result As Double
dim as string snum1=space(21)
dim as string snum2=space(21)
dim as string sresult=space(21)
GetDlgItemText(hWnd, IDC_NUM1, strptr(snum1), 20)
GetDlgItemText(hWnd, IDC_NUM2, strptr(snum2), 20)
num1= val(snum1)
num2= val(snum2)
' Perform calculation based on selected operation
Select Case operation
Case "+"
result = num1 + num2
Case "-"
result = num1 - num2
Case "*"
result = num1 * num2
Case "/"
If num2 <> 0 Then
result = num1 / num2
Else
Print "Cannot divide by zero! Error"
Exit Function
End If
case else
''default addition otherwise result = zero
result = num1 + num2
End Select
sresult=str(result)
' Display result
SetDlgItemText(hWnd, IDC_RESULT, Strptr(sresult))
End Select
End If
Case WM_CLOSE
DestroyWindow(hWnd)
Case WM_DESTROY
PostQuitMessage(0)
Case Else
Return DefWindowProc(hWnd, MainMsg, wParam, lParam)
End Select
Return 0
End Function
' ends
Parse example again updated and alternative
' new parse example halProment, april-august2024, frank bruebach
' alternative example, 22-23/08/2024
'
take kons 'same like: #include konsole
pindex 1
function Parse(pstring expression, delimiter as string= ",", int index ) as pstring
int count = 1
pstring temp = ""
pro d = 1
pro f = 0
pro i = 0
pstring z ""
do
i = instr(d, expression, delimiter)
if i > 0 then
f = i
if count = index then
exit do
end if
count += 1
f += Len(delimiter)
d = f
elseif count = index then
f = Len(expression) + 1
end if
loop until i = 0
return MID(expression,d, f-d)
end function
printl "parse example test"
printl ""
pstring a,b,c
a = parse("one,two,three", ,2) '' ok -> returns "two"
b = parse("xyz", , 1) ' ok -> returns "xyz"
c = parse("xx1x","x", 3) ' ok -> returns "1"
Printl "'" + a + "'"
Printl "'" + b + "'"
Printl "'" + c + "'"
wait
' infos, news
' halProment Basic, update 6, 22. august 2024, time periode march-august 2024, by frank bruebach, germany
' using at own risc, have fun :-)
' halProment.Dll updated, halpromIde24 IDE updated.
' compiling 32, 64 bit possible
' new ones: GUI example and OpgenGL examples (beginning, 3 expl), dim variable suffixes, print alternatives, macros,
parse, parser examples, listview combobox button etcpp
' as I was ill for some weeks in summer time , my left index finger was broken, I couldn't
' make any progress, sorry
' more updates will come, all works in progress, regards, frank
' if you have any question or wishes please ask or contact me via the board here
' 22.+23. August 2024, regards frank
' PS: No AI was involved for halProment ;-)
Class example 3: salary
Code]
' new: simple class example3 with data
' by frank bruebach, halProment, 16-04-2024, 24-08-2024
'
' halProment Class example3
'
class Employee
pstring names2
pstring depts2
pro salarys2
'-------------------/
method constructor(pstring name1="Diana", pstring dept1="Computer Lab", pro salary=2000)
names2 = name1
depts2 = dept1
salarys2 = salary
p? "construct!"
End method
method destructor()
'-------------------/
'destroy strings
del names2
del depts2
del salarys2
p? "destruct!"
end method
method act() as pstring
'-----------------------/
return names2 ", " depts2 ", " salarys2
end method
method act2() as pstring
'-----------------------/
return names2 ", " depts2 ", " salarys2+700
end method
end class
'-------------------/
new Employee diana("Diana","Computer Lab", 2000)
p? diana.act
p? diana.act2
del diana
' ends
Macro new examples vs functions
' -- macro vs function, june,july-august 2024, halProment
' -- new macros implemented with three params go
'
pstring s="Hello macros and functions "
p? s
'
'-- test 1:
'
' macro with three params!
'-- > new! ---------------------- // go
macro abc(one,two,three) msgbox one two three
abc("Hello Avengers ","Hello x-Men ", "Hello Batman") ' result: Hello Avengers Hello x-Men Hello Batman
'-- > new! ---------------------- //
'-- test 2: ------------ //
function abcd(p1 as string,p2 as string, p3 as string) as string
print p1
print p2
print p3
function = 1
end function
abcd("Hello diana3 ","Hello george3 ","Hello paul3 ")
'-- test 3: ------------ //
macro av(z1,z2)
print z1+z2
end macro
av(2,4) '6
'-- test 3a: ------------ //
macro av(z1,z2)
print z1+z2
' end macro not needed
av(4,8) '12
'-- test 4: ------------ //
function one(a as pro) as long
return print a*a
end function
function two(b as pro) as long
return print b*b
end function
one(4) two(6) '36 ' 16 '' 52
'one(4) + two(6) '36 ' 16 '' 52
function one4() as pro
int a=1
return print a*a
end function
function two4() as pro
int b=1
return print b*b
end function
'-- test 5: ------------ //
macro one2(a as pro)
print a*a
end macro
macro two2(b as pro)
print b*b
end macro
one2(4) + two2(6) '36 ' 16 '' 52
' ends