| Welcome, Guest |
You have to register before you can post on our site.
|
|
|
| RUST (from PB Third Party-PluriBASIC) |
|
Posted by: Dale Yarker - 10-26-2024, 02:45 PM - Forum: This and that - friendly chat
- Replies (1)
|
 |
Downloaded/installed Rust. The example code shows curly brace and semicolon fetish I've avoided till now (C was saving RAM when 65K was a lot!).
Downloading Visual Studio (mandatory to have) took a long time. It is 1.42G!
The Rust doc said nothing about what to use to create/edit a source file. Finally just used PBCC Edit. I had to use File Explorer to delete the .bas it kept adding to the name. An appropriate editor is a problem for another day.
Rust uses UTC-8 so internationalization will be easier than current BASICs that are far behind PB (PB has WSTRING, others are ANSI).
Command Prompt for compiling is another thing to improve. I did have success with "Hello world".
Rust has a forum called Community. I think I'll discuss experiences with Rust, rather the PB.
Cheers,
|
|
|
| Etch'n Sketch |
|
Posted by: Rodney Hicks - 09-10-2024, 01:06 PM - Forum: Source Code Library
- No Replies
|
 |
A binary parody of Etch a Sketch, just as deplorably difficult as the original.
Originally created as a re^6-learning exercise.
Attached zip file includes icon, code, and executable.
Comment thread here.
Etchnsketch.zip (Size: 50.73 KB / Downloads: 12)
Code: #COMPILE EXE
#DIM ALL
#DEBUG DISPLAY OFF ' who needs all them error messages anyway?
#INCLUDE "WIN32API.INC"
'#RESOURCE VERSIONINFO
'#RESOURCE FILEFLAGS %VS_FF_PRERELEASE
'#RESOURCE FILEVERSION 1, 0, 0, 1
'#RESOURCE PRODUCTVERSION 1, 0, 0, 1
'#RESOURCE STRINGINFO "0409", "0000"
'#RESOURCE VERSION$ "CompanyName", "INaBIT"
'#RESOURCE VERSION$ "FileDescription", "Presented to users"
'#RESOURCE VERSION$ "FileVersion", "Readable VerNum 1.001"
'#RESOURCE VERSION$ "LegalCopyright", "Copyright 2018 Rod Hicks"
'#RESOURCE VERSION$ "OriginalFilename", "sketchy.bas"
'#RESOURCE VERSION$ "PrivateBuild", "For PB Forum only"
'#RESOURCE VERSION$ "ProductName", "sketchy.bas"
'#RESOURCE VERSION$ "ProductVersion", "1. 00. 00. 10"
'#RESOURCE VERSION$ "SpecialBuild", "This version FREE for PB or PUMP forum members"
#RESOURCE ICON, 7422, "C:\PBWin10\Programs\Etch_n_sketch\sketch.ico" ' may need to adjust to user's settings
TYPE butt
x AS LONG
y AS LONG
w AS LONG
h AS LONG
END TYPE
TYPE knob
x AS LONG
y AS LONG
r AS LONG
END TYPE
TYPE toundo
x AS LONG
y AS LONG
styl AS LONG
stp AS LONG
END TYPE
%SKETCHY = 1000
%BLACK0 = 0
%BLACK1 = 1
%CHARCOAL = %RGB_DARKSLATEGRAY
%RGB_255_252_252_RUDEWHITE = 16579839
%RGB_157_0_0_BLOODRED = 157
%MINX = 40
%MINY = 40
%MAXX = 760
%MAXY = 480
%LBL_XY = 1001
%LBL_STYLE = 1002
%LBL_STEP = 1003
%IDC_UNDO = 1006
%IDC_SHAKE = 1007
%IDC_GOTO = 1008
%IDC_HELPL = 1009
%IDC_SAVE = 1010
%LBL_UNDO = 1011
%LBL_SHAKE = 1012
%LBL_GOTO = 1013
%LBL_HELP = 1014
%LBL_SAVE = 1015
%IDC_XY = 1017
%IDC_STYLE = 1018
%IDC_STEP = 1019
%SKTCH_CURR_XY = %WM_USER+2007
%SKTCH_CURR_STYLE = %WM_USER+2008
%SKTCH_CURR_STEP = %WM_USER+2009
%SKTCH_STFF_UNDO = %WM_USER+2011
%SKTCH_STFF_SHAKE = %WM_USER+2012
%SKTCH_STFF_GOTO = %WM_USER+2013
%SKTCH_STFF_HELP = %WM_USER+2014
%SKTCH_STFF_SAVE = %WM_USER+2015
%SKTCH_LKNOB = %WM_USER+2016
%SKTCH_RKNOB = %WM_USER+2017
%SKTCH_LKNOB_LB_UP = %WM_USER+2024
%SKTCH_LKNOB_RB_UP = %WM_USER+2025
%SKTCH_RKNOB_LB_UP = %WM_USER+2026
%SKTCH_RKNOB_RB_UP = %WM_USER+2027
MACRO txp = TXT.PRINT
MACRO circle (xx,yy,rr,colour)= GRAPHIC ELLIPSE (xx-rr,yy-rr)-(xx+rr,yy+rr),colour,colour
MACRO circlet (xx,yy,rr,colour)= GRAPHIC ELLIPSE (xx-rr,yy-rr)-(xx+rr,yy+rr),colour
FUNCTION hwin(OPT value AS DWORD) AS DWORD ' only use optional parameter to set the feature
STATIC vault AS DWORD
IF ISMISSING(value) THEN
IF vault=0 THEN
EXIT FUNCTION 'get outta here
ELSE
FUNCTION = vault
EXIT FUNCTION
END IF
ELSEIF value=0 THEN
EXIT FUNCTION
ELSE
IF vault=0 THEN ' prevent further assignments to vault
vault=value
END IF
END IF
FUNCTION = vault
END FUNCTION
FUNCTION PBMAIN () AS LONG
LOCAL hwinn AS DWORD
STATIC ww, hh, xx, yy, fnt, fnt1, fnt2, tw, th, temp, bid, ndx, twin AS LONG
STATIC gg, pp, mm AS POINT
LOCAL S, title AS STRING
STATIC currents() AS butt
LOCAL curry() AS STRING
STATIC stff() AS butt
LOCAL stf() AS STRING
DIM curry(1 TO 3)
DIM currents(1 TO 3)
DIM stff(1 TO 5)
DIM stf(1 TO 5)
curry(1)=" X,Y ":curry(2)=" Style ":curry(3)=" Step "
stf(1)=" Undo " :stf(2)= " Shake ":stf(3)=" Go to ":stf(4)=" Help ":stf(5)=" Save "
title= "Etch'n Sketch"
FONT NEW "Comic Sans MS", 18, 1 TO fnt
FONT NEW "Microsoft Sans Serif", 10, 0 TO fnt1
FONT NEW "Lucida Console", 12, 0 TO fnt2
'TXT.WINDOW ("Error checking", 1200,5, 20, 80) TO twin
DIALOG NEW PIXELS, 0, "Etch n Sketch",150,150,800,600, %WS_POPUP, %WS_EX_LAYERED TO hwinn
hwin hwinn
DIALOG SET ICON hwin, "#7422"
DIALOG SET COLOR hwin, %CHARCOAL, %WHITE
CONTROL ADD GRAPHIC, hwin, %SKETCHY, "", 0,0,800,600,%WS_CHILD OR %WS_VISIBLE OR %SS_OWNERDRAW OR %SS_NOTIFY
GRAPHIC CLEAR %WHITE
GRAPHIC ATTACH hwin, %SKETCHY
GRAPHIC SET OVERLAP 1
'SetWindowPos(hwin, %HWND_TOPMOST, 20,400,800,600, %SWP_NOMOVE OR %SWP_NOSIZE) 'to keep on Top
SetLayeredWindowAttributes(hwin, %WHITE, 255, %LWA_ALPHA OR %LWA_Colorkey)
GRAPHIC SET FONT fnt
GRAPHIC TEXT SIZE title TO tw, th
GRAPHIC GET CANVAS TO ww, hh '800, 600
GRAPHIC GET LOC TO xx, yy
GRAPHIC BOX (xx,yy)-(xx+ww, yy+hh), 20, %RED, %RED
GRAPHIC SET POS ((ww/2)-84,5)
GRAPHIC COLOR %RGB_BLUE, -2
GRAPHIC PRINT title
GRAPHIC BOX (xx+40, yy+40)-(ww-40, hh-120), 0, %BLACK, %RGB_GAINSBORO ' the drawing area
circle (80, (hh-60), 40, %RGB_255_252_252_RUDEWHITE),6 'the left knob
circle (80, (hh-60), 35, %RGB_255_252_252_RUDEWHITE)
circle ((ww-80), (hh-60), 40, %RGB_255_252_252_RUDEWHITE),6 ' the right knob
circle ((ww-80), (hh-60), 35, %RGB_255_252_252_RUDEWHITE)
menuu ww ' the exit button
GRAPHIC COLOR %BLACK, -2
GRAPHIC SET FONT fnt2
temp= 225
GRAPHIC TEXT SIZE curry(1) TO tw, th '70 16
GRAPHIC SET POS (temp, 520)
GRAPHIC PRINT curry(1)
GRAPHIC COLOR %RGB_255_252_252_RUDEWHITE, -2
GRAPHIC SET POS (temp, 520+th+5)
GRAPHIC PRINT "360,240"
CONTROL ADD LABEL, hwin, %IDC_XY, "", 225, 520, tw+2, th+2
CONTROL DISABLE hwin, %IDC_XY
CONTROL HIDE hwin, %IDC_XY
temp+=tw
temp+=7
GRAPHIC TEXT SIZE curry(2) TO tw, th '70 16
GRAPHIC SET POS (temp, 520)
GRAPHIC COLOR %BLACK, -2
GRAPHIC PRINT curry(2)
GRAPHIC COLOR %RGB_255_252_252_RUDEWHITE, -2
GRAPHIC SET POS (temp, 520+th+5)
GRAPHIC PRINT " 0 "
CONTROL ADD LABEL, hwin, %IDC_STYLE, "", temp, 520, tw+2, th+2
CONTROL DISABLE hwin, %IDC_STYLE
CONTROL HIDE hwin, %IDC_STYLE
temp+=tw
temp+=7
GRAPHIC TEXT SIZE curry(3) TO tw, th '70 16
GRAPHIC SET POS (temp, 520)
GRAPHIC COLOR %BLACK, -2
GRAPHIC PRINT curry(3)
GRAPHIC COLOR %RGB_255_252_252_RUDEWHITE, -2
GRAPHIC SET POS (temp, 520+th+5)
GRAPHIC PRINT " 1 "
CONTROL ADD LABEL, hwin, %IDC_STEP, "", temp, 520, tw+2, th+2
CONTROL DISABLE hwin, %IDC_STEP
CONTROL HIDE hwin, %IDC_STEP
CONTROL ADD LABEL, hwin, %IDC_UNDO, stf(1), 580, 490, tw, th
CONTROL DISABLE hwin, %IDC_UNDO
CONTROL HIDE hwin, %IDC_UNDO
CONTROL ADD LABEL, hwin, %IDC_SHAKE, stf(2), 580, 508, tw, th
CONTROL DISABLE hwin, %IDC_SHAKE
CONTROL HIDE hwin, %IDC_SHAKE
CONTROL ADD LABEL, hwin, %IDC_GOTO, stf(3), 580, 526, tw, th
CONTROL DISABLE hwin, %IDC_GOTO
CONTROL HIDE hwin, %IDC_GOTO
CONTROL ADD LABEL, hwin, %IDC_HELPL, stf(4), 580, 544, tw, th
CONTROL DISABLE hwin, %IDC_HELPL
CONTROL HIDE hwin, %IDC_HELPL
temp+=tw
temp+=7
CONTROL ADD LABEL, hwin, %IDC_SAVE, stf(5), 580, 562, tw, th
CONTROL DISABLE hwin, %IDC_SAVE
CONTROL HIDE hwin, %IDC_SAVE
GRAPHIC BOX (215, 510)-(455,570),0,%BLACK,-2
GRAPHIC SET POS (230,500)
GRAPHIC COLOR %BLACK,%RED
GRAPHIC PRINT " Current Draw Values "
xx=580
yy=490
GRAPHIC SET FONT fnt2
GRAPHIC COLOR %BLACK, -2
FOR ndx=1 TO 5
GRAPHIC TEXT SIZE stf(ndx) TO tw, th
GRAPHIC BOX (xx,yy)-(xx+tw+2,yy+th+2),0, %RGB_HOTPINK, %RGB_MISTYROSE
s+=FORMAT$(yy)+$CRLF
SELECT CASE ndx
CASE 1
temp= %IDC_UNDO
bid= %LBL_UNDO
CASE 2
temp= %IDC_SHAKE
bid= %LBL_SHAKE
CASE 3
temp= %IDC_GOTO
bid= %LBL_GOTO
CASE 4
temp= %IDC_HELPL
bid= %LBL_HELP
CASE 5
temp= %IDC_SAVE
bid= %LBL_SAVE
END SELECT
CONTROL SET USER hwin, temp, 1, bid
CONTROL SET USER hwin, temp, 2, xx
CONTROL SET USER hwin, temp, 3, yy
CONTROL SET USER hwin, temp, 4, (xx+tw+2)
CONTROL SET USER hwin, temp, 5, (yy+th+2)
GRAPHIC SET POS (xx+1, yy+1)
GRAPHIC PRINT stf(ndx)
yy+= (th+2)
NEXT ndx
CLIPBOARD SET TEXT s
GRAPHIC SET PIXEL (370,220), %BLACK1
DIALOG SHOW MODAL hwin CALL DialogProc
END FUNCTION
SUB knobs(knbs() AS knob)
knbs(1).x=80
knbs(1).y=540
knbs(1).r=40
knbs(2).x=720
knbs(2).y=540
knbs(2).r=40
END SUB
SUB draw_buttons(stff() AS butt)
LOCAL xx, yy, fnt, tw, th, ndx, temp, bid AS LONG
FOR ndx=1 TO 5
SELECT CASE ndx
CASE 1
temp= %IDC_UNDO
bid= %LBL_UNDO
CASE 2
temp= %IDC_SHAKE
bid= %LBL_SHAKE
CASE 3
temp= %IDC_GOTO
bid= %LBL_GOTO
CASE 4
temp= %IDC_HELPL
bid= %LBL_HELP
CASE 5
temp= %IDC_SAVE
bid= %LBL_SAVE
END SELECT
CONTROL GET USER hwin, temp, 1 TO bid
CONTROL GET USER hwin, temp, 2 TO stff(ndx).x
CONTROL GET USER hwin, temp, 3 TO stff(ndx).y
CONTROL GET USER hwin, temp, 4 TO stff(ndx).w
CONTROL GET USER hwin, temp, 5 TO stff(ndx).h
NEXT ndx
END SUB
SUB current(currents() AS butt)
LOCAL ndx, spot, lx, ly, ww, hh AS LONG
FOR ndx= %IDC_XY TO %IDC_STEP
INCR spot
CONTROL GET LOC hwin, ndx TO lx, ly
CONTROL GET SIZE hwin, ndx TO ww, hh
currents(spot).x=lx
currents(spot).y=ly
currents(spot).w=lx+ww
currents(spot).h=ly+hh
NEXT ndx
END SUB
CALLBACK FUNCTION DialogProc() AS LONG
STATIC sketch, oldProc AS DWORD
STATIC gg, pp, mm AS POINT
STATIC ww, hh, ndx, xx, yy, fnt, fnt1, fnt2, tw, th, lknob, rknob, hbmp AS LONG
LOCAL helpwin, xit, c, x, y AS LONG
STATIC angreg, drawing, xxx, yyy, stp, mowed, styl, klr, dir, ub AS LONG 'flags and values
STATIC shakx, shaky AS LONG ' shake values
LOCAL temp, spot, lng AS LONG
STATIC degree, ang AS SINGLE
LOCAL s, tmp, s1, s2, artwork, help_stuff AS STRING
STATIC btns() AS butt
LOCAL bttn() AS butt
STATIC currents() AS butt
LOCAL curry() AS STRING
STATIC stff() AS butt
LOCAL stf() AS STRING
STATIC knbs() AS knob
DIM knbs(1 TO 2)
STATIC back() AS toundo
DIM back(0) 'back() to undo
DIM curry(1 TO 3)
DIM currents(1 TO 3)
DIM stff(1 TO 5)
DIM stf(1 TO 5)
DIM btns(1 TO 4)
klr=%BLACK1
FONT NEW "Lucida Console", 12, 0 TO fnt2
FONT NEW "Lucida Console", 12, 1 TO fnt
FONT NEW "Lucida Console", 10.5, 0 TO fnt1
DIALOG GET LOC hwin TO shakx, shaky
IF drawing=0 THEN
GRAPHIC SET POS (370,220)
drawing =1
xxx =360
yyy =240
stp =1
back(0).x =xxx ' set the base values for the undo feature
back(0).y =yyy
back(0).styl =0
back(0).stp =stp
END IF
IF currents(1).x=0 THEN
draw_buttons stff()
current currents()
knobs knbs()
END IF
SELECT CASE CB.MSG
CASE %WM_INITDIALOG
CONTROL HANDLE CB.HNDL, %SKETCHY TO sketch
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
DIALOG SET USER CB.HNDL, 2, sketch
CASE %WM_COMMAND
CASE %SKTCH_CURR_XY
SetWindowLong sketch, %GWL_WNDPROC, oldProc '70 16 267 '40, 760, 40, 480
GetCursorPos pp
s=FORMAT$(xxx)+","+FORMAT$(yyy)
where:
tmp= INPUTBOX$("Indicate comma separated x, y coordinates"+$CRLF+"Min x=40 Max x=760"+$CRLF+"Min y=40 Maxy=480", "Coordinates", s, pp.x, pp.y-240)
tmp=REMOVE$(tmp," ")
spot=INSTR(tmp,",")
IF spot=0 THEN where
lng=LEN(tmp)
s1=LEFT$(tmp,spot-1)
s2=RIGHT$(tmp,lng-spot)
IF VAL(s1)<40 OR VAL(s1)>760 THEN where
IF VAL(s2)<40 OR VAL(s2)>480 THEN where
xxx=VAL(s1)
yyy=VAL(s2)
GRAPHIC BOX (225, 539)-(305, 561),0,%RED, %RED
GRAPHIC COLOR %RGB_255_252_252_RUDEWHITE,-2
GRAPHIC SET POS (225, 541)
GRAPHIC PRINT tmp
dir=0
Move_it xxx, yyy, styl, stp, dir, back()
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
CASE %SKTCH_CURR_STYLE
SetWindowLong sketch, %GWL_WNDPROC, oldProc
GetCursorPos pp
s=FORMAT$(styl)
there:
tmp= INPUTBOX$("Select for style"+$CRLF+"0 Solid"+$CRLF+"1 Blank", "Style Value", s, pp.x, pp.y-240)
styl=VAL(tmp)
IF styl<0 OR styl>1 THEN GOTO there
IF styl=1 THEN
klr=%RGB_GAINSBORO
ELSE
klr= %BLACK1
END IF
GRAPHIC BOX (305, 539)-(355, 561),0,%RED, %RED
GRAPHIC COLOR %RGB_255_252_252_RUDEWHITE,-2
GRAPHIC SET POS (325, 541)
GRAPHIC PRINT styl
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
CASE %SKTCH_CURR_STEP
SetWindowLong sketch, %GWL_WNDPROC, oldProc
GetCursorPos pp
s=FORMAT$(stp)
here:
tmp= INPUTBOX$("Select a number (1 to 19 inclusive)", "Step Value", s, pp.x, pp.y-240)
stp=VAL(tmp)
IF stp<1 OR stp>19 THEN GOTO here
GRAPHIC BOX (404, 539)-(435, 561),0,%RED, %RED
GRAPHIC COLOR %RGB_255_252_252_RUDEWHITE,-2
GRAPHIC SET POS (389, 541)
GRAPHIC PRINT stp
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
CASE %SKTCH_STFF_UNDO
SetWindowLong sketch, %GWL_WNDPROC, oldProc
ub=UBOUND(back())
IF ub=0 THEN
xxx =360
yyy =240
MSGBOX "Cannot go back any further!"
EXIT IF
ELSEIF back(ub).stp=1 THEN
GRAPHIC SET PIXEL (back(ub).x, back(ub).y), %RGB_GAINSBORO
ELSE
GRAPHIC LINE (back(ub).x, back(ub).y)-(back(ub-1).x, back(ub-1).y), %RGB_GAINSBORO 'work to do
END IF
IF ub>0 THEN
DECR ub
xxx= back(ub).x
yyy= back(ub).y
REDIM PRESERVE back(ub)
ELSE
xxx =360
yyy =240
END IF
update_xy xxx, yyy
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
CASE %SKTCH_STFF_SHAKE
SetWindowLong sketch, %GWL_WNDPROC, oldProc
IF UBOUND(back())=0 THEN oops
DIALOG SET LOC hwin, shakx+4, shaky
GRAPHIC WAITKEY$ (15)
DIALOG SET LOC hwin, shakx-3, shaky+4
GRAPHIC WAITKEY$ (15)
GRAPHIC BOX (40, 40)-(760, 480), 0, %BLACK, %RGB_GAINSBORO ' the drawing area
xxx =360
yyy =240
stp =1
styl =0
REDIM back(0) 'back() to undo
back(0).x =xxx
back(0).y =yyy
back(0).styl =0
back(0).stp =stp
DIALOG SET LOC hwin, shakx, shaky-3
GRAPHIC WAITKEY$ (15)
DIALOG SET LOC hwin, shakx, shaky
GRAPHIC WAITKEY$ (15)
DIALOG SET LOC hwin, shakx, shaky+3
GRAPHIC WAITKEY$ (15)
DIALOG SET LOC hwin, shakx, shaky
update_xy xxx,yyy
GRAPHIC BOX (404, 539)-(435, 561),0,%RED, %RED
GRAPHIC COLOR %RGB_255_252_252_RUDEWHITE,-2
GRAPHIC SET POS (389, 541)
GRAPHIC PRINT stp
GRAPHIC BOX (305, 539)-(355, 561),0,%RED, %RED
GRAPHIC COLOR %RGB_255_252_252_RUDEWHITE,-2
GRAPHIC SET POS (325, 541)
GRAPHIC PRINT styl
oops:
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
CASE %SKTCH_STFF_GOTO
SetWindowLong sketch, %GWL_WNDPROC, oldProc
GetCursorPos pp
s=FORMAT$(xxx)+","+FORMAT$(yyy)
town:
tmp= INPUTBOX$("Indicate comma separated x, y coordinates"+$CRLF+"Min x=40 Max x=760"+$CRLF+"Min y=40 Maxy=480", "Coordinates", s, pp.x, pp.y-240)
tmp=REMOVE$(tmp," ")
spot=INSTR(tmp,",")
IF spot=0 THEN GOTO town
lng=LEN(tmp)
s1=LEFT$(tmp,spot-1)
s2=RIGHT$(tmp,lng-spot)
IF VAL(s1)<40 OR VAL(s1)>760 THEN GOTO town
IF VAL(s2)<40 OR VAL(s2)>480 THEN GOTO town
xxx=VAL(s1)
yyy=VAL(s2)
GRAPHIC BOX (225, 539)-(305, 561),0,%RED, %RED
GRAPHIC COLOR %RGB_255_252_252_RUDEWHITE,-2
GRAPHIC SET POS (225, 541)
GRAPHIC PRINT tmp
dir=5 'move to xxx,yyy without drawing
Move_it xxx, yyy, styl, stp, dir, back()
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
CASE %SKTCH_STFF_HELP
SetWindowLong sketch, %GWL_WNDPROC, oldProc
GRAPHIC WINDOW NEW "Etch'n Sketch Help", 150,150,800,600 TO helpwin
GRAPHIC ATTACH helpwin, 0
GRAPHIC WINDOW STABILIZE helpwin
GRAPHIC SET FONT fnt2
GRAPHIC SET WORDWRAP 1
help_them fnt1, fnt
DO
SLEEP 1
GRAPHIC WINDOW CLICK TO c, x, y
LOOP UNTIL ISTRUE c
GRAPHIC SET WORDWRAP 0
GRAPHIC WINDOW END
GRAPHIC ATTACH hwin, %SKETCHY
'MSGBOX "Remember to create a help file."
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
CASE %SKTCH_STFF_SAVE
SetWindowLong sketch, %GWL_WNDPROC, oldProc
GetCursorPos pp
GRAPHIC BITMAP NEW 760, 480 TO hbmp
GRAPHIC ATTACH hbmp,0
GRAPHIC COPY hwin, %SKETCHY, (40,40)-(760,480) TO (0,0)
DISPLAY SAVEFILE 0, pp.x-400, pp.y-400, "Save Artwork", "", "*.bmp", "", ".bmp", %OFN_EXPLORER TO artwork
GRAPHIC SAVE artwork
GRAPHIC ATTACH hwin, %SKETCHY
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
CASE %SKTCH_LKNOB_LB_UP '= %WM_USER+2024
SetWindowLong sketch, %GWL_WNDPROC, oldProc
dir=1 'right Left button up on left knob- move step pixels to right
Move_it xxx, yyy, styl, stp, dir, back()
update_xy xxx,yyy
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
CASE %SKTCH_LKNOB_RB_UP '= %WM_USER+2025
SetWindowLong sketch, %GWL_WNDPROC, oldProc
dir=2 'left Right button up on left knob- move step pixels to left
Move_it xxx, yyy, styl, stp, dir, back()
update_xy xxx,yyy
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
CASE %SKTCH_RKNOB_LB_UP '= %WM_USER+2026
SetWindowLong sketch, %GWL_WNDPROC, oldProc
dir=3 'up Left button up on right knob- move step pixels up
Move_it xxx, yyy, styl, stp, dir, back()
update_xy xxx,yyy
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
CASE %SKTCH_RKNOB_RB_UP '= %WM_USER+2027
SetWindowLong sketch, %GWL_WNDPROC, oldProc
dir=4 'down Right button up on right knob- move step pixels down
Move_it xxx, yyy, styl, stp, dir, back()
update_xy xxx,yyy
oldProc = SetWindowLong(GetDlgItem(CB.HNDL, %SKETCHY), %GWL_WNDPROC, CODEPTR(SubClassProc))
DIALOG SET USER CB.HNDL, 1, oldProc
CASE %WM_DESTROY ' <- The dialog is about to be destroyed
'TXT.END
DIALOG GET USER CB.HNDL, 1 TO oldProc
DIALOG GET USER CB.HNDL, 2 TO sketch
IF oldProc THEN ' remove subclassing before exit
SetWindowLong sketch, %GWL_WNDPROC, oldProc
END IF
END SELECT
END FUNCTION
SUB help_them(fnt1 AS LONG, fnt2 AS LONG)
GRAPHIC PRINT
GRAPHIC SET FONT fnt2
GRAPHIC PRINT " There are 11 clickable items in this program."+SPACE$(5)+"Click here to close."
GRAPHIC PRINT
GRAPHIC PRINT " 1.- Exit "+ $DQ+"X"+ $DQ+" in the top right."
GRAPHIC SET FONT fnt1
GRAPHIC PRINT " Exits the program."'+ $CRLF+ $CRLF+ _
GRAPHIC PRINT
GRAPHIC SET FONT fnt2
GRAPHIC PRINT " 2.- The left"+ $DQ+" knob"+$DQ+", the left hand white circle."'+ $CRLF
GRAPHIC SET FONT fnt1
GRAPHIC PRINT " Left button up draws to the right, depending on style and step."
GRAPHIC PRINT " Right button up draws to the left, depending on style and step."'+ $CRLF+ $CRLF+ _
GRAPHIC SET FONT fnt2
GRAPHIC PRINT " 3.- The right"+ $DQ+ " knob"+$DQ+", the right hand white circle."
GRAPHIC SET FONT fnt1
GRAPHIC PRINT " Left button up draws upwards, depending on style and step."
GRAPHIC PRINT " Right button up draws downwards, depending on style and step."
GRAPHIC PRINT
GRAPHIC SET FONT fnt2
GRAPHIC PRINT " 4.- The "+ $DQ+"X,Y"+$DQ+" in the "+ $DQ+"Current Draw Values"+$DQ+" box."
GRAPHIC SET FONT fnt1
GRAPHIC PRINT " Left button down will produce an InputBox to input a location to draw to."
GRAPHIC PRINT " Upon acceptance of the input, a line is drawn to the location specified "
GRAPHIC PRINT " from the last point referenced."
GRAPHIC SET FONT fnt2
GRAPHIC PRINT " 5.- The "+ $DQ+"Style"+$DQ+" in the "+ $DQ+"Current Draw Values"+$DQ+" box."
GRAPHIC SET FONT fnt1
GRAPHIC PRINT " Left button down will show an InputBox for a choice of black or field colour."
GRAPHIC PRINT " Accepted choice will remain in effect until changed or the drawing cleared."
GRAPHIC SET FONT fnt2
GRAPHIC PRINT " 6.- The "+ $DQ+"Step"+$DQ+" in the "+ $DQ+"Current Draw Values"+$DQ+" box."
GRAPHIC SET FONT fnt1
GRAPHIC PRINT " Left button down will show an InputBox for a choice between 1 and 19 pixels "
GRAPHIC PRINT " to draw with each knob action.
GRAPHIC PRINT " Accepted choice will remain in effect until changed or the drawing cleared.
GRAPHIC PRINT
GRAPHIC SET FONT fnt2
GRAPHIC PRINT " 7.- "+$DQ+"Undo"+$DQ+" button."
GRAPHIC SET FONT fnt1
GRAPHIC PRINT " Left button down will remove last draw action, and subsequent clicks will "
GRAPHIC PRINT " remove draw operations in the reverse order of being drawn. "
GRAPHIC SET FONT fnt2
GRAPHIC PRINT " 8.- "+$DQ+"Shake"+$DQ+" button."
GRAPHIC SET FONT fnt1
GRAPHIC PRINT " Shake is an euphemism for Clear and left button down will shake the program "
GRAPHIC PRINT " and reset to default X,Y, style, and Step values.
GRAPHIC SET FONT fnt2
GRAPHIC PRINT " 9.- "+$DQ+"Goto"+$DQ+" button.
GRAPHIC SET FONT fnt1
GRAPHIC PRINT " Left button down will produce an InputBox to input a location to move to "
GRAPHIC PRINT " without drawing."
GRAPHIC PRINT " The next draw operation will use this point as the last point referenced."
GRAPHIC SET FONT fnt2
GRAPHIC PRINT " 10.-"+$DQ+"Help"+$DQ+" button."
GRAPHIC SET FONT fnt1
GRAPHIC PRINT " This extensive help file is displayed, covering the program.
GRAPHIC SET FONT fnt2
GRAPHIC PRINT " 11.-"+$DQ+"Save"+$DQ+" button."
GRAPHIC SET FONT fnt1
GRAPHIC PRINT " Prompts for a file name and saves the drawing canvas to user's specified folder.
END SUB
SUB update_xy(xxx AS LONG, yyy AS LONG)
LOCAL tmp AS STRING
tmp=FORMAT$(xxx)+","+FORMAT$(yyy)
GRAPHIC BOX (225, 539)-(305, 561),0,%RED, %RED
GRAPHIC COLOR %RGB_255_252_252_RUDEWHITE,-2
GRAPHIC SET POS (225, 541)
GRAPHIC PRINT tmp
END SUB
SUB Move_it(xxx AS LONG, yyy AS LONG, styl AS LONG, stp AS LONG, att AS LONG, back() AS toundo)
STATIC moves, klr AS LONG
IF att=5 THEN
klr= %RGB_GAINSBORO
ELSEIF styl=0 THEN
klr= %BLACK1
ELSE
klr= %RGB_GAINSBORO
END IF
IF moves=UBOUND(back()) THEN
INCR moves
ELSE
moves=UBOUND(back())+1
END IF
' updating current x,y
SELECT CASE AS LONG att
CASE 0 ' current X,Y
GRAPHIC LINE (back(moves-1).x,back(moves-1).y)-(xxx, yyy), klr
CASE 1 'right
IF (xxx+stp)< %MAXX THEN 'check border restrictions
IF stp=1 THEN
INCR xxx
GRAPHIC SET PIXEL (xxx,yyy), klr
ELSE
xxx+=stp
GRAPHIC LINE (back(moves-1).x,back(moves-1).y)-(xxx, yyy), klr
END IF
END IF
CASE 2 'left
IF (xxx-stp)> %MINX THEN 'check border restrictions
IF stp=1 THEN
DECR xxx
GRAPHIC SET PIXEL (xxx,yyy), klr
ELSE
xxx-=stp
GRAPHIC LINE (back(moves-1).x,back(moves-1).y)-(xxx, yyy), klr
END IF
END IF
CASE 3 'up
IF (yyy-stp)> %MINY THEN 'check border restrictions
IF stp=1 THEN
DECR yyy
GRAPHIC SET PIXEL (xxx,yyy), klr
ELSE
yyy-=stp
GRAPHIC LINE (back(moves-1).x,back(moves-1).y)-(xxx, yyy), klr
END IF
END IF
CASE 4 'down
IF (yyy+stp)< %MAXY THEN 'check border restrictions
IF stp=1 THEN
INCR yyy
GRAPHIC SET PIXEL (xxx,yyy), klr
ELSE
yyy+=stp
GRAPHIC LINE (back(moves-1).x,back(moves-1).y)-(xxx, yyy), klr
END IF
END IF
CASE 5 ' Go to
GRAPHIC LINE (back(moves-1).x,back(moves-1).y)-(xxx, yyy), klr
END SELECT
REDIM PRESERVE back(0 TO moves)
back(moves).x =xxx
back(moves).y =yyy
back(moves).styl =styl
back(moves).stp =stp
END SUB
SUB menuu(ww AS LONG)
LOCAL www AS LONG
www=ww-50
GRAPHIC WIDTH 2 ' the X box in the top right corner
GRAPHIC BOX (www-20, 0)-(www,19), 0, %RGB_157_0_0_BLOODRED, %RED
GRAPHIC LINE (www-20,0)-(www,19), %RGB_157_0_0_BLOODRED
GRAPHIC LINE (www-20,19)-(www,0), %RGB_157_0_0_BLOODRED
GRAPHIC WIDTH 1
END SUB
FUNCTION distance(gg AS POINT, knbs AS knob) AS LONG
LOCAL dist AS SINGLE
dist=SQR(((gg.x-knbs.x)*(gg.x-knbs.x))+((gg.y-knbs.y)*(gg.y-knbs.y)))
IF dist>=knbs.r THEN
FUNCTION=0
ELSE
FUNCTION=1
END IF
END FUNCTION
FUNCTION SubClassProc(BYVAL hWnd AS DWORD, BYVAL wMsg AS DWORD, _
BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
'--------------------------------------------------------------------
' SubClass procedure adapted from PB Samples
'------------------------------------------------------------------
LOCAL lRes, oldProc AS DWORD
STATIC gg, pp, mm AS POINT
STATIC ww, hh, moving, xx, yy, fnt, fnt1, tw, th, lknob, rknob AS LONG
STATIC knbs() AS knob
DIM knbs(1 TO 2)
STATIC btns() AS butt
DIM btns(1 TO 4)
STATIC dcur() AS butt
DIM dcur(1 TO 5)
STATIC stff() AS butt
LOCAL stf() AS STRING
DIM stff(1 TO 5)
DIM stf(1 TO 5)
STATIC currents() AS butt
DIM currents(1 TO 3)
IF currents(1).x=0 THEN
draw_buttons stff()
current currents()
knobs knbs()
END IF
'------------------------------------------------------------------
' Messages shall normally be passed on to the original procedure
' with CallWindowProc for processing, which is why we stored the
' return value from SetWindowLong in the dialog's USER memory.
' We'll use the GetParent API call to get parent dialog's handle.
'------------------------------------------------------------------
DIALOG GET USER GetParent(hWnd), 1 TO oldProc
IF oldProc = 0 THEN EXIT FUNCTION
GRAPHIC GET CANVAS TO ww, hh
'------------------------------------------------------------------
SELECT CASE AS LONG wMsg
CASE %WM_LBUTTONUP
GetCursorPos gg
screentoclient(hwin, gg)
IF ISTRUE distance(gg, knbs(1)) THEN
SendMessage(hwin, %SKTCH_LKNOB_LB_UP, 0, 0)
ELSEIF ISTRUE distance(gg, knbs(2)) THEN
SendMessage(hwin, %SKTCH_RKNOB_LB_UP, 0, 0)
END IF
CASE %WM_RBUTTONUP
GetCursorPos gg
screentoclient(hwin, gg)
IF ISTRUE distance(gg, knbs(1)) THEN
SendMessage(hwin, %SKTCH_LKNOB_RB_UP, 0, 0)
ELSEIF ISTRUE distance(gg, knbs(2)) THEN
SendMessage(hwin, %SKTCH_RKNOB_RB_UP, 0, 0)
END IF
CASE %WM_LBUTTONDOWN
GetCursorPos gg
screentoclient(hwin, gg)
IF gg.x>ww-70 AND gg.y<20 THEN
GRAPHIC DETACH
DIALOG END hwin
END IF
SELECT CASE gg.x
CASE stff(1).x TO stff(1).w
SELECT CASE gg.y
CASE stff(1).y TO stff(1).h
SendMessage(hwin, %SKTCH_STFF_UNDO, 0, 0)
CASE stff(2).y TO stff(2).h
SendMessage(hwin, %SKTCH_STFF_SHAKE, 0, 0)
CASE stff(3).y TO stff(3).h
SendMessage(hwin, %SKTCH_STFF_GOTO, 0, 0)
CASE stff(4).y TO stff(4).h
SendMessage(hwin, %SKTCH_STFF_HELP, 0, 0)
CASE stff(5).y TO stff(5).h
SendMessage(hwin, %SKTCH_STFF_SAVE, 0, 0)
END SELECT
when:
CASE currents(1).x TO currents(1).w
IF gg.y>=currents(1).y AND gg.y<=currents(1).h THEN
SendMessage(hwin, %SKTCH_CURR_XY, 0, 0)
END IF
CASE currents(2).x TO currents(2).w
IF gg.y>=currents(2).y AND gg.y<=currents(2).h THEN
SendMessage(hwin, %SKTCH_CURR_STYLE, 0, 0)
END IF
CASE currents(3).x TO currents(3).w
IF gg.y>=currents(3).y AND gg.y<=currents(3).h THEN
SendMessage(hwin, %SKTCH_CURR_STEP, 0, 0)
END IF
END SELECT
who:
END SELECT
FUNCTION = CallWindowProc(oldProc, hWnd, wMsg, wParam, lParam)
END FUNCTION
|
|
|
|
| Faster leap year code. |
|
Posted by: Dale Yarker - 09-07-2024, 01:42 PM - Forum: Source Code Library
- No Replies
|
|
This is roughly 3 times faster than the usual three MOD operations method.
Code: ! push eax 'for pseudo MOD, dividend and quotient
! mov FebDays, 28& 'not a leap year pre-set
! mov eax, 3???
! and eax, Year 'conditionally equivalent MOD 4
! jz MOD100 '0 is possible leap year
! jmp Done
MOD100:
! push ebx 'for divisor
! push edx 'for high part of dividend, remainder (MOD)
! xor edx, edx
! mov eax, Year
! mov ebx, 100???
! div ebx
! cmp edx, 0??? 'does MOD 100 = 0 ?
! pop edx
! pop ebx
! jz MOD400 '0 is possibly not a leap year
! jmp Is29Days 'non 0 is a leap year
MOD400:
! and eax, 3??? 'EAX has Year\100, so pseudo MOD 4 again
! jnz Done
! Is29Days:
! mov FebDays, 29&
Done:
! pop eax '
Longer description at: http://www.yarker-dsyc.info/D_Notebook/P...yDays.html
|
|
|
|
| Discussing and posting |
|
Posted by: Tillmann Viefhaus - 06-09-2024, 12:33 PM - Forum: Suggestions and discussion about PUMP
- Replies (21)
|
|
Hi, I hope its possible to post threads and post answers since it was closed down on powerbasic forum for all members from the EU. I just could reach Garys site with the intros and downloads. PowerBasic is too good to just leave it especially because it fullfils the requirements of todays stand alone software even as 32 bit compiler.
|
|
|
|
| Test posting |
|
Posted by: Albert Richheimer - 05-14-2024, 07:23 AM - Forum: Test forum
- Replies (10)
|
 |
this is a posting to test the BB codes.
Code: gThreadAlive=%TRUE
thread create ttdsPing(0) to gThread
SetThreadPriority gThread,%thread_priority_idle
gMainALoX = val(GetRegValue(%HKEY_CURRENT_USER,$REGISTRY,$MAINALOX))
gMainALoY = val(GetRegValue(%HKEY_CURRENT_USER,$REGISTRY,$MAINALOY))
gMutaALoX = val(GetRegValue(%HKEY_CURRENT_USER,$REGISTRY,$MUTAALOX))
gMutaALoY = val(GetRegValue(%HKEY_CURRENT_USER,$REGISTRY,$MUTAALOY))
' Connect to ttds
' ---------------
'
gDSConn=trm_Connect(gServerURL,gttdsPort,gttdsData,gttdsUser,gttdsPass,0)
if gDSConn < 0 then
gErrorText="Unable to connect user "+gttdsUser+" to database "+ _
gttdsData+":"+$cr+"Error "+format$(abs(gDSConn))+" - "+ _
trm_ErrorMessage(gDSConn)
msgbox gErrorText,%mb_iconerror or %mb_taskmodal,$ERR_CAPTION
exit function
end if
' Open ttds files
' ---------------
'
gDLDAT = trm_Open(gDSConn,gDLDAT_File,1)
if gDLDAT < 0 then
gErrorText="ERR#001 Cannot open "+gDLDAT_File+". Code "+format$(gDLDAT)
msgbox gErrorText,%mb_iconerror or %mb_taskmodal,$ERR_CAPTION
goto closedown
end if
dim abg(0) as global DLGES at varptr(dld)
Code tags obviously works fine - important for us programmers.
|
|
|
|
|
