Liberty BASIC Community Forum
« Example programs - update »

Welcome Guest. Please Login or Register.
Sep 21st, 2017, 12:17am


Rules|Home|Help|Search|Recent Posts|Notification


« Previous Topic | Next Topic »
Pages: 1 2  Notify Send Topic Print
 veryhotthread  Author  Topic: Example programs - update  (Read 681 times)
Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Example programs - bitmap.bas
« Reply #15 on: Aug 4th, 2017, 11:04am »

Should be called bitmapbutton.bas

Uses graphics window for no reason so,

Code:
    'this program sets and amends the bmp background of a bmpbutton
    'first load two spare bmp images and name them
    loadbmp "arrow", "bmp\arrwbttn.bmp"
    loadbmp "blue", "bmp\bluebttn.bmp"
    'set up the bmpbuttons with their initial blank image, another bmp from file
    bmpbutton #main.button1, "bmp\blank4.bmp", [button1Click], UL, 22, 11
    bmpbutton #main.button2, "bmp\blank4.bmp", [button2Click], UL, 22, 46
    open "Bmpbutton demo" for window as #main
    #main "trapclose [quit]"
    wait

    [button1Click]
    #main.button2 "setfocus"        'setfocus highlights the named button
    #main.button2 "bitmap arrow"    'use the named bmp images in the buttons
    #main.button1 "bitmap blue"
    wait

    [button2Click]
    #main.button1 "setfocus"
    #main.button1 "bitmap arrow"
    #main.button2 "bitmap blue"

    'the button that has focus will fire if "Enter is pressed.

    wait



    [quit]
    close #main
    unloadbmp "arrow"
    unloadbmp "blue"
    end
 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Example programs - boxes.bas
« Reply #16 on: Aug 5th, 2017, 03:03am »

I found boxes.bas to be pretty ugly so have made quite a few changes.

It also made me think about nomainwin and trapclose. Most of the examples don't do that sort of housekeeping. Perhaps they should.

Code:
 nomainwin
    'This program draws some boxes and introduces the drawing commands
    'flush, segment, delsegment and redraw
    'all you will see on screen is THREE boxes, use the debugger and step
    'through the program to see SIX boxes being drawn initially.

    'set up some colors
    dim color$(6)
    color$(1) = "red"
    color$(2) = "brown"
    color$(3) = "yellow"
    color$(4) = "green"
    color$(5) = "blue"
    color$(6) = "darkpink"



    open "Boxes" for graphics as #1
        #1 "trapclose [quit]"

        'now draw SIX boxes, flush to save SIX drawn segments
        'we will later remove some of those segments
        #1 "down ; size 2"
        for x = 10 to 60 step 10
            #1 "color "; color$(x/10)
            #1 "place ";x;" ";x
            #1 "box "; x+60 ; " ";x+60
            #1 "flush"
        next x

        'now, just to prove it can be done, we will remove every
        'second segment and then redraw the remaining THREE segments
        'first we get the last drawn segment number
        #1 "segment segId"
        'now loop and delete every second one
        for x = 1 to segId - 1 step 2
            #1 "delsegment "; x
        next x
        'redraw all remaining segments
        #1 "redraw"
        wait

    [quit]
    close #1
    end

 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Example programs - update
« Reply #17 on: Aug 5th, 2017, 03:10am »

Also, can you have too many rem statements? cant see the code for the trees?
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Example programs - update
« Reply #18 on: Aug 5th, 2017, 03:59am »

Does anyone have a link or code for a bullet proof example of browseforfolder.bas

I find the code in this link to be flawed and I get protection errors.

http://libertybasic.conforums.com/index.cgi?board=lb4alphatest&action=display&num=1355501551

Actually, Stephan's code seems to be holding up, both Chris and Mathesons code give protection errors but so far not Stephan's.

Need some expert input on this one.


Code:
  crlf$ = chr$(13) + chr$(10)
    Hint$ = "Select any folder"; crlf$; "--------------------"; crlf$; "or CANCEL to exit"
    Caption$ = "Select destination folder"
    RootDir$ = "11"
    SelectedDir$ = "C:\Programme\7-Zip"
    DialogStyle$ = ""

    print BrowseForFolder$(Caption$, Hint$, RootDir$, SelectedDir$, DialogStyle$)
end

function BrowseForFolder$(Caption$, Hint$, RootDirID$, StartDir$, Style$)
' returns the selected folder
'
' Hint$ can use up to three lines for the new style dialog (default)
' and up to two lines for the old style dialog,
' use CRLF to seperate the lines
'
' using the old style dialog includes a status text

    open "ole32" for dll as #ole32

    BIF.RETURNONLYFSDIRS   = 1
    BIF.DONTGOBELOWDOMAIN  = 2
    BIF.STATUSTEXT         = 4
    BIF.RETURNFSANCESTORS  = 8
    BIF.EDITBOX            = hexdec("10")
    BIF.VALIDATE           = hexdec("20")
    BIF.NEWDIALOGSTYLE     = hexdec("40")
    BIF.USENEWUI           = BIF.NEWDIALOGSTYLE or BIF.EDITBOX
    BIF.BROWSEINCLUDEURLS  = hexdec("80")
    BIF.UAHINT             = hexdec("100")
    BIF.NONEWFOLDERBUTTON  = hexdec("200")
    BIF.NOTRANSLATETARGETS = hexdec("400")
    BIF.BROWSEFORCOMPUTER  = hexdec("1000")
    BIF.BROWSEFORPRINTER   = hexdec("2000")
    BIF.BROWSEINCLUDEFILES = hexdec("4000")
    BIF.SHAREABLE          = hexdec("8000")

    STRUCT BrowseInfo,_
        hWndOwner       As ulong,_
        pIDLRoot        As ulong,_
        pszDisplayName$ As ptr,_
        lpszTitle$      As ptr,_
        ulFlags         As uLong,_
        lpfnCallback    As uLong,_
        lParam$         As ptr,_
        iImage          As uLong,_
        dlgCaption$     As ptr

    BrowseInfo.lpszTitle$.struct  = Hint$
    BrowseInfo.pIDLRoot.struct    = GetSpecialfolderIDL(hexdec(RootDirID$))
    BrowseInfo.lParam$.struct     = StartDir$ + chr$(0)
    BrowseInfo.dlgCaption$.struct = Caption$

    BrowseInfo.pszDisplayName$.struct = space$(_MAX_PATH)

    select case lower$(Style$)
        case "old"
            BrowseInfo.ulFlags.struct = BIF.RETURNONLYFSDIRS or BIF.STATUSTEXT
        case else
            BrowseInfo.ulFlags.struct = BIF.RETURNONLYFSDIRS or BIF.NEWDIALOGSTYLE or BIF.NONEWFOLDERBUTTON
    end select

    callback lpfn, BrowseCallbackProc(handle, ulong, ulong, ulong), ulong

    BrowseInfo.lpfnCallback.struct = lpfn

    calldll #shell32, "SHBrowseForFolder",_
        BrowseInfo as struct,_
        lpIDList   as ulong

    If lpIDList > 0 Then
        BrowseForFolder$ = SHGetPathFromIDList$(lpIDList)

        calldll #ole32, "CoTaskMemFree",_
            lpIDList as ulong,_
            result   as void
    End If

    close #ole32
end function

function BrowseCallbackProc(Handle, Message, lParam, lpData)
    BFFM.INITIALIZED     = 1
    BFFM.SELCHANGED      = 2
    BFFM.VALIDATEFAILEDA = 3
    BFFM.VALIDATEFAILEDW = 4
    BFFM.IUNKNOWN        = 5

    BFFM.SETSTATUSTEXTA = _WM_USER + 100
    BFFM.ENABLEOK       = _WM_USER + 101
    BFFM.SETSELECTIONA  = _WM_USER + 102
    BFFM.SETSELECTIONW  = _WM_USER + 103
    BFFM.SETSTATUSTEXTW = _WM_USER + 104
    BFFM.SETOKTEXT      = _WM_USER + 105
    BFFM.SETEXPANDED    = _WM_USER + 106

    select case Message
        case BFFM.INITIALIZED
            Folder$ = winstring(lpData)
            Caption$ = winstring(BrowseInfo.dlgCaption$.struct)
            if Caption$ <> "" then call SetWindowText Handle, Caption$
            if Folder$ <> "" then call PostMessageString Handle, BFFM.SETSELECTIONA, 1, Folder$
        case BFFM.SELCHANGED
            selFolder$ = SHGetPathFromIDList$(lParam)
            if selFolder$ <> "" then call PostMessageString Handle, BFFM.SETSTATUSTEXTA, 1, selFolder$
    end select

    SetFolderPath = 0
end function

function SHGetPathFromIDList$(lpIDList)
    sPath$ = space$(_MAX_PATH) + chr$(0)

    calldll #shell32, "SHGetPathFromIDListA",_
        lpIDList as ulong,_
        sPath$   as ptr,_
        result   as boolean

    SHGetPathFromIDList$ = trim$(sPath$)
end function

sub SetWindowText Handle, Text$
    calldll #user32, "SetWindowTextA", _
        Handle as ulong, _
        Text$  as ptr, _
        result as ulong
end sub

sub PostMessageString Handle, Message, wParam, lParam$
    calldll #user32, "PostMessageA", _
        Handle  as ulong, _
        Message as ulong, _
        wParam  as ulong, _
        lParam$ as ptr, _
        result  as ulong
end sub

Function GetSpecialfolderIDL(CSIDL)
' Get Special Folders
' from Mastering Liberty BASIC 3
'
' Folder ID 00: CSIDL_DESKTOP
' Folder ID 01: CSIDL_INTERNET
' Folder ID 02: CSIDL_PROGRAMS
' Folder ID 03: CSIDL_CONTROLS
' Folder ID 04: CSIDL_PRINTERS
' Folder ID 05: CSIDL_PERSONAL
' Folder ID 06: CSIDL_FAVORITES
' Folder ID 07: CSIDL_STARTUP
' Folder ID 08: CSIDL_RECENT
' Folder ID 09: CSIDL_SENDTO
' Folder ID 0A: CSIDL_BITBUCKET
' Folder ID 0B: CSIDL_STARTMENU
' Folder ID 0C: CSIDL_MYDOCUMENTS
' Folder ID 0D: CSIDL_MYMUSIC
' Folder ID 0E: CSIDL_MYVIDEO
' Folder ID 0F: Error
' Folder ID 10: CSIDL_DESKTOPDIRECTORY
' Folder ID 11: CSIDL_DRIVES
' Folder ID 12: CSIDL_NETWORK
' Folder ID 13: CSIDL_NETHOOD
' Folder ID 14: CSIDL_FONTS
' Folder ID 15: CSIDL_TEMPLATES
' Folder ID 16: CSIDL_COMMON_STARTMENU
' Folder ID 17: CSIDL_COMMON_PROGRAMS
' Folder ID 18: CSIDL_COMMON_STARTUP
' Folder ID 19: CSIDL_COMMON_DESKTOPDIRECTORY
' Folder ID 1A: CSIDL_APPDATA
' Folder ID 1B: CSIDL_PRINTHOOD
' Folder ID 1C: CSIDL_LOCAL_APPDATA
' Folder ID 1D: CSIDL_ALTSTARTUP
' Folder ID 1E: CSIDL_COMMON_ALTSTARTUP
' Folder ID 1F: CSIDL_COMMON_FAVORITES
' Folder ID 20: CSIDL_INTERNET_CACHE
' Folder ID 21: CSIDL_COOKIES
' Folder ID 22: CSIDL_HISTORY
' Folder ID 23: CSIDL_COMMON_APPDATA
' Folder ID 24: CSIDL_WINDOWS
' Folder ID 25: CSIDL_SYSTEM
' Folder ID 26: CSIDL_PROGRAM_FILES
' Folder ID 27: CSIDL_MYPICTURES
' Folder ID 28: CSIDL_PROFILE
' Folder ID 29: CSIDL_SYSTEMX86
' Folder ID 2A: CSIDL_PROGRAM_FILESX86
' Folder ID 2B: CSIDL_PROGRAM_FILES_COMMON
' Folder ID 2C: CSIDL_PROGRAM_FILES_COMMONX86
' Folder ID 2D: CSIDL_COMMON_TEMPLATES
' Folder ID 2E: CSIDL_COMMON_DOCUMENTS
' Folder ID 2F: CSIDL_COMMON_ADMINTOOLS
' Folder ID 30: CSIDL_ADMINTOOLS
' Folder ID 31: CSIDL_CONNECTIONS
' Folder ID 32: Error
' Folder ID 33: Error
' Folder ID 34: Error
' Folder ID 35: CSIDL_COMMON_MUSIC
' Folder ID 36: CSIDL_COMMON_PICTURES
' Folder ID 37: CSIDL_COMMON_VIDEO
' Folder ID 38: CSIDL_RESOURCES
' Folder ID 39: CSIDL_RESOURCES_LOCALIZED
' Folder ID 3A: CSIDL_COMMON_OEM_LINKS
' Folder ID 3B: CSIDL_CDBURN_AREA
' Folder ID 3C: Error
' Folder ID 3D: CSIDL_COMPUTERSNEARME
' Folder ID 3E: CSIDL_PROFILES
' Folder ID 3F: Error

    struct IDL, _
        cb   As uLong, _
        abID As short

    calldll #shell32, "SHGetSpecialFolderLocation",_
        0     as ulong, _
        CSIDL as ulong, _
        IDL   as struct,_
        ret   as ulong

    if ret = 0 then GetSpecialfolderIDL = IDL.cb.struct
End Function


 
« Last Edit: Aug 5th, 2017, 04:07am by Rod » User IP Logged

tsh73
Board Moderator

member is offline

Avatar

Anatoly (real name)


PM

Gender: Male
Posts: 1681
xx Re: Example programs - update
« Reply #19 on: Aug 5th, 2017, 05:36am »

Quote:
Also, can you have too many rem statements? cant see the code for the trees?


You sure can.
example "ascii.bas" shows that.

So. Program should have one (or two) line(s) explaining that it does / demonstrates
and then comments only there needed. (according to "that it demonstrates")
(really may vary from user to user, but I think explaining Input and For is too much).

So my idea of "ascii.bas":
Code:
'This lists the ascii value of characters in a string

    input "Please enter a string >"; entry$

    'for all characters in a string
    for i = 1 to len(entry$)
        'use mid$() function to get i-th letter
        c$=mid$(entry$,i,1)
        'then asc() to get the ascii value
        print c$, asc(c$)
    next
 



User IP Logged

damned Dog in the Manger
tsh73
Board Moderator

member is offline

Avatar

Anatoly (real name)


PM

Gender: Male
Posts: 1681
xx Re: Example programs - update
« Reply #20 on: Aug 5th, 2017, 05:46am »

Quote:
It also made me think about nomainwin and trapclose. Most of the examples don't do that sort of housekeeping. Perhaps they should.

I think they could

Also, I think nomainwin should be placed after initial comment explaining that this program does.
User IP Logged

damned Dog in the Manger
Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Example programs - update
« Reply #21 on: Aug 5th, 2017, 10:28am »

Agreed, posted your ascii code. We need to fix flush code, quite often flush is just thrown in at the end and no segment management is shown.

Posted Stefan's browseForFolder solution, any feedback welcome.

User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Example programs - Buttons1.bas
« Reply #22 on: Aug 5th, 2017, 10:30am »

This needed flush fixed, I removed size$/size and rather than prompt/notice just limited the input.


Code:
'This is a turtle graphics demo for Liberty BASIC
    'it shows how menu and buttons input coexists

    nomainwin

    size = 100
    color$ = "Red"

    button #1, "Triangle", [triangle], LR, 170, 10
    button #1, "Square", [square], LR, 90, 10
    button #1, "Size", [size], LR, 25, 10
    button #1, "Red", [colorRed], UL, 5, 5
    button #1, "Blue", [colorBlue], UL, 46, 5
    button #1, "Green", [colorGreen], UL, 95, 5
    menu #1, &Colors, &red, [colorRed], &blue, [colorBlue], &green, [colorGreen]
    menu #1, &Options, &square, [square], &triangle, [triangle], &size, [size], |, &quit, [quit]
    open "Turtle graphics" for graphics_nsb as #1

    #1 "trapclose [quit]"
    wait


[triangle]
    #1 "delsegment seg"
    #1 "color "; color$
    #1 "cls ; home ; down ; north"
    for x = 1 to size
        #1 "turn 122 ; go "; str$(x*2)
    next x
    #1 "flush seg"
    wait


[square]
    #1 "delsegment seg"
    #1 "color "; color$
    #1 "cls ; home ; down ; north"
    for x = 1 to size
        #1 "turn 88 ; go "; str$(x*2)
    next x
    #1 "flush seg"
    wait

[colorRed]
    color$ = "red"
    wait

[colorBlue]
    color$ = "blue"
    wait

[colorGreen]
    color$ = "green"
    wait

[size]
    prompt "What size figure?"; size
    if size<0 then size=10
    if size>200 then size=200
    wait

[quit]
    close #1
    end



 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Example programs - call32-4.bas
« Reply #23 on: Aug 5th, 2017, 11:04am »

The call32-4 and call32-5.bas programs simply need replaced.

They don't work well and show stuff that Liberty can do natively.

So It would be good to show off a few API tricks in a short demo. Say Move Window, Get Pixel Color Run .exe and say run Sound Recorder.

Anyone willing to ick that up and code a short demo of a few useful API tricks?
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Example programs - update
« Reply #24 on: Aug 7th, 2017, 02:21am »

Richard has pointed out some flaws in clock2.bas and offers this alternative.

Quote:
Richard Russell <richard@rtrussell.co.uk>

Rod,

The code of 'clock2.bas' (even in your revised version) is seriously
flawed.  Specifically, consider this snippet:

     ' erase each hand if its position has changed
     if oldHours <> hours then #clock "size 2 ; color white ; turn ";
oldHours * 30 + int(oldMinutes/2) ; " ; go 19 ; home ; color black ;
north" : oldHours = hours

The comment says "erase each hand if its position has changed" but the
hour hand moves every two minutes, not every hour - you can see that
from the calculation of its angle, which includes the term
'int(minutes/2)'.  The 'if oldHours <> hours' condition results in the
'erase' action, which should be happening every two minutes, happening
only once per hour!

The effect of this error is that rather than the hour hand 'moving' it
appears to get thicker and thicker (as a result if being drawn in the
new position without the old position being erased) until sanity is
restored on the next hour.  Clearly that isn't right.

A related issue is that whilst the calculation of the hour-hand angle
(correctly) includes a contribution from the minutes, the calculation of
the minute-hand angle doesn't include a contribution from the seconds
(which it should).  The result is a clock which, as the time approaches
the next minute (say at 55 seconds), appears - at least on a quick
glance - to be a whole minute slow!

The correct calculation of the minute-hand angle would be:

     #clock "home; north; turn "; minutes * 6 + int(seconds/10); "; go 38"

An elegant way of fixing both these problems is to work with 'degree'
angles throughout, so when comparing 'old' with 'new' and when drawing
or undrawing the hands the same values are always used.  I have listed
just such a modified version below.

Regards,

Richard.



Code:

     'clock2.bas  - a clock program for Liberty BASIC
     nomainwin
     WindowWidth = 120
     WindowHeight = 144
     open "Clock" for graphics_nsb_nf as #clock
     #clock "trapclose [exit]"

     #clock "fill white"
     for angle = 0 to 330 step 30
         #clock "up ; home ; north ; turn "; angle
         #clock "go 40 ; down ; go 5"
     next angle

     #clock "flush segId"

     timer 1000, [display]
     wait

[display]  ' call this only when seconds has changed

     time$ = time$()
     second.deg = val(right$(time$, 2)) * 6
     minute.deg = val(mid$(time$, 4, 2)) * 6 + int(second.deg / 60)
     hour.deg = val(time$) * 30 + int(minute.deg / 12)
     if hour.deg >= 360 then hour.deg = hour.deg - 360

     ' delete the named ie last drawn segment
     #clock "delsegment segId"

     ' erase each hand if its position has changed
     #clock "color white"
     if oldSecond.deg <> second.deg then #clock "size 1 ; home ; north ; 
turn "; oldSecond.deg ; " ; go 38" : oldSecond.deg = second.deg
     if oldMinute.deg <> minute.deg then #clock "size 2 ; home ; north ; 
turn "; oldMinute.deg ; " ; go 38" : oldMinute.deg = minute.deg
     if oldHour.deg <> hour.deg then     #clock "size 2 ; home ; north ; 
turn "; oldHour.deg; " ; go 19" : oldHour.deg = hour.deg

     ' redraw all three hands, second hand first
     #clock "color black"
     #clock "size 1 ; home ; north ; turn "; second.deg ; " ; go 38"
     #clock "size 2 ; home ; north ; turn "; minute.deg ; " ; go 38"
     #clock "size 2 ; home ; north ; turn "; hour.deg; " ; go 19"

     ' flush to end segment, then get the next segment id #
     #clock "flush segId"
     wait

[exit]

     timer 0   'prevent timer ticks from building up
     confirm "Quit Clock?"; q$
     if q$ = "yes" then
         close #clock
     else
         timer 1000, [display]
         wait
     end if

     end
 
« Last Edit: Aug 7th, 2017, 02:21am by Rod » User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Example programs - update
« Reply #25 on: Aug 9th, 2017, 11:04am »

Straw man to replace files.bas

Any thoughts?



Code:
    'lets write two files to disc to use in this demo
    'then open the second for input only so blocking
    'writing to it, We will also look for a non existant
    'file

    'make sure DefaultDir$ is a full path name
    if right$(DefaultDir$,1)<>"\" then DefaultDir$=DefaultDir$+"\"

    open DefaultDir$+"file1.dat" for output as #1
    #1 "1"
    close #1
    'open DefaultDir$+"file2.dat" for output as #1
    '#1 "2"
    'close #1
    open DefaultDir$+"file2.dat" for input as #1


    'Now lets check and see if these files exit
    'and are accessible for writing to
    dim info$(1, 1)

    if fileExists(DefaultDir$,"file1.dat") then print fileAccessible(DefaultDir$,"file1.dat")
    if fileExists(DefaultDir$,"file2.dat")then print fileAccessible(DefaultDir$,"file2.dat")
    if fileExists(DefaultDir$,"file3.dat")then print fileAccessible(DefaultDir$,"file2.dat")
    wait

function fileExists(p$,f$)
    files p$,f$, info$(
    if val(info$(0, 0)) > 0 then
        fileExists=1 'success
        'remove this print statement
        print p$+f$+" exists"
      else
        fileExists=0 'fail
        'remove this print statement
        print p$+f$+" doesn't exist"
    end if
end function

function fileAccessible(p$,f$)
    on error goto [catch]
    open p$+f$ for append as #test
    close #test
    fileAccessible=1 'success
    print p$+f$+" is accessible"
    goto [done]
    [catch]
    fileAccessible=0 'fail
    print p$+f$+" is not accessible"
    [done]
    'on error
end function





 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Example programs - InKey$
« Reply #26 on: Aug 11th, 2017, 10:43am »

I think the original needs improved, this isn't that much better, any takers for an improved version?

Edit refreshed the example, we probably need a really simple example and a this more complex example?


Code:
     'INKEY.BAS - how to use the Inkey$ variable
    'nomainwin

    open "Inkey$ example" for graphics as #graph
    #graph "when characterInput [fetch]"
    #graph "setfocus"
    #graph "\\Press any key or key combination"
    wait

[fetch]

    'a key or key combination was pressed, fetch it
    'some keys issue a key down and a key up message. For example Shift Control and Enter do so
    'Esc issues three messages, press some keys and observe the mainwin data
    #graph  "when characterInput"
    key$ = Inkey$

    'show what we got in the mainwin
    'key messages are either one or two bytes long
    print len(key$),
    if len(key$)=1 then
        print "-- ";asc(right$(key$,1)),right$(key$,1)
    else
        print right$("  ";asc(left$(key$,1)),2);" ";asc(right$(key$,1)),right$(key$,1)
    end if


    'get the key value of the right most character of a two byte message or
    'simply the key value of a single byte message
    key=asc(right$(key$,1))

    'if we have received a a single byte message it is most likely a printable character
    'but some system keys like Enter,Tab and Backspace can send single byte messages
    'so lets filter out the single byte alpha numeric messages and send the rest on as system key messages
    if key >=32 and key<=126 and len(key$)=1 then
            #graph "\";key$

    'if we have received a two byte message or a single byte message that is not alpha numeric
    'then we have a system key message
    else
        'seek out its virtual keycode value
        'Go here for full list http://msdn.microsoft.com/en-us/library/dd375731(VS.85).aspx
        select case key
            case 3
                #graph "\Ctrl C COPY"
            case 22
                #graph "\Ctrl V PASTE"
            case _VK_SHIFT
                #graph "\Shift"
            case _VK_RETURN
                #graph "\Enter"
            case _VK_LEFT
                #graph "\Left Arrow"
            case _VK_RIGHT
                #graph "\Right Arrow"
            case _VK_UP
                #graph "\Up Arrow"
            case _VK_DOWN
                #graph "\Down Arrow"
            case _VK_PRIOR
                #graph "\Page Up"
            case _VK_NEXT
                #graph "\Page Down"
            case _VK_HOME
                #graph "\Home"
            case _VK_BACK
                #graph "\Back"
            case _VK_END
                #graph "\End"
            case _VK_DELETE
                #graph "\Delete"
            case _VK_CONTROL
                #graph "\Control"
            case else
                #graph "\Not in list"
        end select
    end if

    print #graph, "when characterInput [fetch]"
    print #graph, "setfocus"
    wait
 
« Last Edit: Aug 12th, 2017, 11:21am by Rod » User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Example programs - update
« Reply #27 on: Aug 14th, 2017, 08:36am »

Messed about with lander.bas to make it more playable, slowed it down, dusted off the graphics and made it easier to pass the landing criteria. Also added fuel use display and a crash report.

Any other improvements required?


Code:
    'Lander.bas
    'written by Carl Gundel
    'carlg@world.std.com
    'Needs at least Liberty BASIC v2.0
    'This file is contributed to the public domain

    'Use the left or right arrow keys to rotate left or right
    'Use the up or down arrow to increase or decrease thrust
    'If you run out of fuel you will drop to the planet

    'You must make a VERY gentle and level landing
    'on one of the flat areas!

    'open game window

    'nomainwin
    WindowWidth = 800
    WindowHeight = 600
    UpperLeftX = int((DisplayWidth-WindowWidth)/2)
    UpperLeftY = int((DisplayHeight-WindowHeight)/2)
    dim terrain(WindowWidth)
    graphicbox #lander.fuel 10,30,10,500
    open "Lunar Lander" for graphics_nsb as #lander
    #lander "when characterInput [control]"
    #lander "trapclose [quit]"

    call makeSprites
    call setBackground
    #lander "spritexy lem 50 50"
    #lander.fuel "down ; fill yellow ; size 4 ; north ;color green"

[startGame] 'initialize
    #lander "setfocus"
    fuel = 250
    altitude = 0
    attitude = 0
    longitude = 10
    thrust = 0
    call setHorizSpeed 8
    call setVertSpeed 0
    call gravityAccelerate
    timer 100, [timerTicked]
    startTime = time$("milliseconds")
    wait


[timerTicked]   'This is the main simulation routine!

    frames = frames + 1
    if altitude <= terrain(longitude+15) - 24 then
        fuel=fuel-thrust
        if fuel<=0 then thrust =0
        call setAttitude attitude
        call applyThrust thrust, attitude
        call gravityAccelerate
        altitude = altitude + getVertSpeed()
        longitude = max(0, min(785, longitude + getHorizSpeed()))
        #lander "spritexy lem "; longitude; " "; altitude
        #lander "drawsprites"
        #lander.fuel "cls ;fill yellow ;place 4 500 ; go ";fuel*2
    else
        timer 0
        crash = landerCrashed(longitude, attitude,fuel)
        if crash then
            cause$="You crashed!"+chr$(13)
            if crash and 1 then cause$=cause$+"Not verticle"+chr$(13)
            if crash and 2 or crash and 4 then cause$=cause$+"Too fast"+chr$(13)
            if crash and 8 then cause$=cause$+"Missed the base"+chr$(13)
            if crash and 16 then cause$=cause$+"Out of fuel"
            notice cause$
          else
            notice "Successful landing!"
        end if
        confirm "Try again?"; answer
        if answer then [startGame] else [quit]
    end if

    wait

[quit]
    timer 0
    close #lander

    end

[control]
    key = asc(right$(Inkey$,1))
    select case key
        case _VK_UP
            thrustInput=thrustInput+(thrustInput<9)
            if thrustInput then thrust = (thrustInput - 1) / 8 * 0.55 + 0.333

        case _VK_DOWN
            thrustInput=thrustInput-(thrustInput>0)
            if thrustInput then thrust = (thrustInput - 1) / 8 * 0.55 + 0.333

        case _VK_LEFT
            attitude = attitude - 22.5
            if attitude < -0.01 then attitude = 337.5

        case _VK_RIGHT
            attitude = attitude + 22.5
            if attitude > 337.51 then attitude = 0
    end select
    wait

function landerCrashed(xPosition, attitude,fuel)
    if attitude<89 or attitude>91 then landerCrashed=landerCrashed+1
    if getVertSpeed() > 4 then landerCrashed=landerCrashed+2
    if getHorizSpeed() > 4 then landerCrashed=landerCrashed+4
    if terrain(xPosition+8) <> terrain(xPosition+16) then landerCrashed=landerCrashed+8
    if fuel<=0 then landerCrashed=landerCrashed+16
end function

sub makeSprites

    open "lem" for graphics as #makeSprites
    #makeSprites "down"
    #makeSprites "place 0 31 ; backColor black ; boxfilled 640 73"
    for x = 0 to 15
      y = 1
      call drawLEM x, y, 270 + x * 22.5, 2, "black"
      y = 2
      call drawLEM x, y, 270 + x * 22.5, 2, "darkgray"
      call drawLEM x, y, 270 + x * 22.5, 1, "lightgray"
      call getSprite x
    next x
    close #makeSprites
    #lander "addsprite lem lem0 lem1 lem2 lem3 lem4 lem5 lem6 lem7 lem8 lem9 lem10 lem11 lem12 lem13 lem14 lem15"

end sub

sub drawLEM xPosition, yPosition, uncorrectedAngle, penSize, color$
    angle = uncorrectedAngle
    #makeSprites "north ; color "; color$; " ; up ; turn "; angle
    #makeSprites "place "; (xPosition)*30+15; " "; (yPosition-1)*30+15
    #makeSprites "size "; penSize
    #makeSprites "up ; go 4 ; down ; circlefilled 8"
    #makeSprites "turn 75 ; go 4 ; turn 180 ; go 4"
    #makeSprites "turn 30 ; go 4 ; turn 180 ; go 4 ; turn 255"
    #makeSprites "up ; turn 160 ; go 8"
    #makeSprites "down ; go 4 ; turn 110"
    #makeSprites "go 8 ; turn 110 ; go 4"
    #makeSprites "place "; (xPosition)*30+15; " "; (yPosition-1)*30+15
    #makeSprites "north ; up ; turn "; angle
    #makeSprites "go 4 ; turn 125 ; go 8 ; down ; turn 45 ; go 8"
    #makeSprites "place "; (xPosition)*30+15; " "; (yPosition-1)*30+15
    #makeSprites "north ; up ; turn "; angle
    #makeSprites "go 4 ; turn 235 ; go 8 ; down ; turn -45 ; go 8"

end sub

sub setBackground
    #lander "down ; fill black"
    'stars
    for s = 1 to 100
        c=int(rnd(0)*100+156)
        #lander "color ";c;" ";c;" ";c
        #lander "size ";int(rnd(0)*4)
        #lander "set ";rnd(0)*800;" ";rnd(0)*600
    next
    call drawTerrain
    #lander "getbmp stars 0 0 800 600"
    #lander "background stars"
end sub

sub getSprite spritNum
    spriteX = spritNum * 30
    #makeSprites "getbmp lem"; spritNum; " "; spriteX; " 1 30 60"
end sub

sub setHorizSpeed xSpeed
    vars(0) = xSpeed
end sub

sub setVertSpeed ySpeed
    vars(1) = ySpeed
end sub

function getHorizSpeed()
    getHorizSpeed = vars(0)
end function

function getVertSpeed()
    getVertSpeed = vars(1)
end function

sub setAttitude degrees
    #lander "spriteimage lem lem"; int(degrees / 22.5)
end sub

sub gravityAccelerate
    call setVertSpeed getVertSpeed() + 0.3'(6/18)
end sub

sub applyThrust qtyFuel, angle
    angleXform = angle / 180 * 3.141592
    call setHorizSpeed getHorizSpeed() - (qtyFuel/2) * cos(angleXform)
    call setVertSpeed getVertSpeed() - (qtyFuel/2) * sin(angleXform)
end sub


sub drawTerrain

    rate1 = rnd(1) / (rnd(1) * 10 + 5)
    rate2 = rnd(1) / (rnd(1) * 5 + 5)
    #lander "down ; size 1 ; color white"

    for x = 0 to 799 step 1
        if rnd(1) < 0.015 then gosub [makeLandingZone]
        holder1 = holder1+rate1
        holder2 = holder2+rate2
        holder3 = holder3+sin(holder2)/20
        y = 400+int(sin(holder1)*50)+int(cos(holder2)*50)+int(cos(holder3)*15)
        terrain(x) = y
        c=rnd(0)*50+50
        #lander "color ";c;" ";c;" ";c;" ;  line ";x;" 600 ";x; " ";y
    next x
    goto [endSub]

[makeLandingZone]

    width = int((rnd(1)*4+2)/3)
    for lz = x to min(799, x + 34 * width)
        terrain(lz) = y
        c=rnd(0)*50+50
        #lander "color ";c;" ";c;" ";c;" ;  line ";lz;" 600 ";lz; " ";y
    next lz
    #lander "color red ; line ";x;" ";y;" ";lz;" ";y
    x = lz
  return

[endSub]

end sub
 
User IP Logged

tsh73
Board Moderator

member is offline

Avatar

Anatoly (real name)


PM

Gender: Male
Posts: 1681
xx Re: Example programs - update
« Reply #28 on: Aug 15th, 2017, 05:36am »

rndtest.bas
: since main window serve no point it should have NOMAINWIN
Also SCAN in a main loop would be good (to allow closing window while loop runs)
User IP Logged

damned Dog in the Manger
Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Example programs - update
« Reply #29 on: Aug 15th, 2017, 11:59am »

Agreed, away from home will tackle it in few days
User IP Logged

Pages: 1 2  Notify Send Topic Print
« Previous Topic | Next Topic »

Rules|Home|Help|Search|Recent Posts|Notification

Donate $6.99 for 50,000 Ad-Free Pageviews!

| |

This forum powered for FREE by Conforums ©
Sign up for your own Free Message Board today!
Terms of Service | Privacy Policy | Conforums Support | Parental Controls