Liberty BASIC Community Forum
« Sample Program .bas code »

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 3 4 5 6  7 Notify Send Topic Print
 locked  Author  Topic: Sample Program .bas code  (Read 901 times)
Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program keypress.bas
« Reply #45 on: Aug 11th, 2017, 10:50am »

keypress.bas


Added a scan


Code:
'This is a very fast way to check specific keys on the fly
'during program execution. No need for when characterInput
'and associated handler.

print "Press the arrow keys, the space bar, or Esc to exit."

[loop]
    scan
    if keyState(_VK_LEFT) then print "Left is pressed."
    if keyState(_VK_RIGHT) then print "Right is pressed."
    if keyState(_VK_UP) then print "Up is pressed."
    if keyState(_VK_DOWN) then print "Down is pressed."
    if keyState(32) then print "Space is pressed."
    if keyState(27) then print "Esc pressed.  Ended." : end
goto [loop]

function keyState(keycode)
    calldll #user32, "GetAsyncKeyState", _
        keycode AS long, _
        state AS long
    if state <> 0 then keyState = 1
    '1 = pressed
end function

 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program ladder.bas
« Reply #46 on: Aug 11th, 2017, 10:52am »

ladder.bas

Simply does not work on my PC, perhaps we need some other note playing example.
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program lander.bas
« Reply #47 on: Aug 14th, 2017, 08:31am »

lander.bas

A bit of a dust down, some new graphics, uses the cursor keys, easier to land and fuel use is shown. More playable I think.


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

    '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,10,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 and fuel>0 then
        fuel=fuel-thrust
        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+7) <> terrain(xPosition+22) 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



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

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program lb3edit.bas
« Reply #48 on: Aug 14th, 2017, 10:02am »

lb3edit.bas

should perhaps be called lbedit.bas


unchanged


Code:
    'lb3edit.bas - a simple text editor with open, save, and save as features

    nomainwin
    WindowWidth = 320
    WindowHeight = 240
    menu #window, "&File","&Open", [open], "&Save As...", [saveAs], "&Save", [save], | , "E&xit", [quit]
    menu #window, "Edit"
    menu #window, "&Help",  "&About", [about]
    texteditor #window.te 5, 10, 300, 170
    open "Liberty BASIC Edit" for window as #window
    #window.te "!font courier_new 9"
    #window.te "!autoresize"
    #window "trapclose [quit]"
    wait

[open]
    filedialog "Open a txt file", "*.txt", filename$
    if filename$ = "" then wait
    open filename$ for input as #filein
    #window.te "!contents #filein";
    close #filein
    wait

[saveAs]
    filedialog "Save as...", "*.txt", filename$
    if filename$ = "" then wait

[save]
    if filename$ = "" then [SaveAs]
    open filename$ for output as #fileout
    #window.te "!contents? filetext$";
    print #fileout, filetext$;
    close #fileout
    wait

[about]
    notice "lb3edit.bas - a simple texteditor example"
    wait

[quit]
    close #window
    end

 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program ledclock.bas
« Reply #49 on: Aug 14th, 2017, 10:04am »

ledclock.bas


unchanged save for adding white space and removing :

Code:
    ' App Title: LED Function Demo
    ' Programmer: Andy Amaya
    ' Date: October 27, 2003
    NoMainWin


    Dim clr$(10)
    For x = 1 To 10
        Read x$
        clr$(x)=x$
    Next x
    Data "128 160 255","red","255 212 64","blue","green","cyan","255 128 32","pink","192 255 0","white"

    WindowWidth=800
    WindowHeight=600
    UpperLeftX=(DisplayWidth-WindowWidth)/2
    UpperLeftY=(DisplayHeight-WindowHeight)/2
    Open "LED Functions" For graphics_nsb As #g
    #g "Down; Trapclose [done]; BackColor 0 0 0; Fill 0 0 0"
    hwinDC=GetDC(hWnd(#g))
    Call SetBkMode hwinDC, 1

[Begin]
    #g "Setfocus"
    #g "when characterInput [nex1]; when leftButtonDown [nex1]; when rightButtonDown [nex2]"
    Gosub [AllDigits]
    Wait


[nex1]
    #g "Setfocus"
    #g "when characterInput [nex2]; when leftButtonDown [nex2]; when rightButtonDown [Begin]"
    Gosub [RandomDigits]
    Wait

[nex2]
    #g "Setfocus"
    #g,"when characterInput [Begin]; when leftButtonDown [Begin]; when rightButtonDown [nex1]"
    Gosub [LEDClock]
    Wait

[done]
    Call ReleaseDC hWnd(#g),hwinDC
    Close #g
    End

[AllDigits]
    #g "Cls;Color white"
    Call text 350,12,"Scalable LED's"
    Call text 257,32,"Left click to proceed ... Right click to go back"
    For pen=0 To 5
        wide=(pen+1)*4:high=wide/4:xLED=(800-(30*wide+10*high))/2
        For i=0 To 9
            #g "Color ";clr$(Rand(1,10))
            Call LED xLED+i*(3*wide+high+pen+1)-24,3*wide*pen+40,i,pen+1,pen+1
        Next i
    Next pen
    #g "Flush ;Segment segNum ;Delsegment ";segNum-1
    Return

[RandomDigits]
    #g "Cls;Color white"
    Call text 326,12,"Random Number LEDs"
    Call text 257,32,"Left click to proceed ... Right click to go back"
    clrCount=clrCount+1
    If clrCount>10 Then clrCount=1
    exitFlag=0
    newColor$=clr$(clrCount)
    #g,"Color ";newColor$
    #g "SetFocus;when leftButtonDown [nex2];when rightButtonDown [Begin]"

[digitLoop]
    If msTimer<Time$("ms") Then
        msTimer=Time$("ms")+60
        num$=Str$(Rand(111111,999999))
        ln=Len(num$)
        #g "Color black;BackColor black;Place 204 250;BoxFilled 600 350;Color ";newColor$
        For i=1 To ln
            dig=Asc(Mid$(num$,i,1))-48
            Call LED 204+i*48,250,dig,4,2
        Next i
    End If
    #g,"Flush;Segment segNum;Delsegment ";segNum-1
    Scan
    Goto [digitLoop]


[LEDClock]
    wide=16
    high=wide/4
    xTime=(800-(18*wide+8*high))/2
    yTime=(600-(6*wide-high))/2
    #g "Cls;Color 255 255 255"
    Call text 335,12,"Old Skool LED clock"
    Call text 257,32,"Left click to proceed ... Right click to go back"
    r=70
    g=70
    b=70
    #g "Color ";r;" ";g;" ";b
    inc=5
    colr=r
    For i=0 To 84
        Call SuperEllipse 400,304,184+i,74+i,3,36,2,0
        colr=colr+inc
        If colr>255 Then inc=inc*-1:colr=colr+inc
        r=colr
        g=g+inc
        b=b+inc
        #g "Color ";r;" ";g;" ";b
    Next i
    #g "Color blue":Call text 309,412,Chr$(34)+"LED Clock"+Chr$(34)+" by Andy Amaya"
    #g "when characterInput [Begin];when leftButtonDown [Begin];when rightButtonDown [nex1]"

[clockLoop]
    If sysTime$<>Time$() Then
        sysTime$=Time$()
        #g "Color 0 0 0;BackColor 0 0 0;Place 250 254;BoxFilled 552 347;Color green"
        x=xTime
        y=yTime
        wide=16
        high=4
        hr1=Val(Mid$(sysTime$,1,1))
        hr2=Val(Mid$(sysTime$,2,1))
        mn1=Val(Mid$(sysTime$,4,1))
        mn2=Val(Mid$(sysTime$,5,1))
        sc1=Val(Mid$(sysTime$,7,1))
        sc2=Val(Mid$(sysTime$,8,1))
        Call LED x,y,hr1,4,2:x=x+3*wide
        Call LED x,y,hr2,4,2:x=x+3*wide+high
        Call Oval x,y+2*wide,high,high,2,0,4
        Call Oval x,y+4*wide+high/2,high,high,2,0,4:x=x+3*high
        Call LED x,y,mn1,4,2:x=x+3*wide
        Call LED x,y,mn2,4,2:x=x+3*wide+high
        Call Oval x,y+2*wide,high,high,2,0,4
        Call Oval x,y+4*wide+high/2,high,high,2,0,4:x=x+3*high
        Call LED x,y,sc1,4,2:x=x+3*wide
        Call LED x,y,sc2,4,2
    End If
    #g "Flush;Segment segNum;Delsegment ";segNum-1
    Scan
    Goto [clockLoop]


Function Rand(lo,hi)
    Rand=int(rnd(0)*(hi-lo+1)+lo)
End Function

SUB LED x, y, digit, ledSize, penSize
    If ledSize<.5 Then ledSize=.5
    wide=ledSize*4.0:high=wide/4.0
    If digit>=10 Then digit=digit-Int(digit/10)*10
    If penSize<1 Then penSize=1
    #g "Size ";penSize
    Select digit
        Case 0
            Call Oval x+wide+high,y+2*high,wide,high,penSize,0,6
            Call Oval x+high,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+2*wide+high,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+high,y+4*wide+high,wide,high,penSize,90,6
            Call Oval x+2*wide+high,y+4*wide+high,wide,high,penSize,90,6
            Call Oval x+wide+high,y+5*wide+2*high,wide,high,penSize,0,6
        Case 1
            Call Oval x+wide+high,y+2*wide-high,wide+high/4,high,penSize,90,6
            Call Oval x+wide+high,y+4*wide+3*high/2,wide+3*high/2,high,penSize,90, 6
        Case 2
            Call Oval x+wide+high,y+2*high,wide,high,penSize,0,6
            Call Oval x+2*wide+high,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+wide+high,y+3*wide,wide,high,penSize,0,6
            Call Oval x+high,y+4*wide+high,wide,high,penSize,90,6
            Call Oval x+wide+high,y+5*wide+2*high,wide,high,penSize,0,6
        Case 3
            Call Oval x+wide+high,y+2*high,wide,high,penSize,0,6
            Call Oval x+2*wide+high,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+wide+high,y+3*wide,wide,high,penSize,0,6
            Call Oval x+2*wide+high,y+4*wide+high,wide,high,penSize,90,6
            Call Oval x+wide+high,y+5*wide+2*high,wide,high,penSize,0,6
        Case 4
            Call Oval x+high,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+2*wide+high,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+wide+high,y+3*wide,wide,high,penSize,0,6
            Call Oval x+2*wide+high,y+4*wide+3*high/2,wide+3*high/2,high,penSize,90,6
        Case 5
            Call Oval x+wide+high,y+2*high,wide,high,penSize,0,6
            Call Oval x+high,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+wide+high,y+3*wide,wide,high,penSize,0,6
            Call Oval x+2*wide+high,y+4*wide+high,wide,high,penSize,90,6
            Call Oval x+wide+high,y+5*wide+2*high,wide,high,penSize,0,6
        Case 6
            Call Oval x+high,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+wide+high,y+3*wide,wide,high,penSize,0,6
            Call Oval x+high,y+4*wide+high,wide,high,penSize,90,6
            Call Oval x+2*wide+high,y+4*wide+high,wide,high,penSize,90,6
            Call Oval x+wide+high,y+5*wide+2*high,wide,high,penSize,0,6
        Case 7
            Call Oval x+wide+high,y+2*high,wide,high,penSize,0,6
            Call Oval x+2*wide+high,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+2*wide+high,y+4*wide+3*high/2,wide+3*high/2,high,penSize,90,6
        Case 8
            Call Oval x+wide+high+pen,y+2*high,wide,high,penSize,0,6
            Call Oval x+high+pen,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+2*wide+high+pen*2,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+wide+high+pen*2,y+3*wide,wide,high,penSize,0,6
            Call Oval x+high+pen*2,y+4*wide+high,wide,high,penSize,90,6
            Call Oval x+2*wide+high+pen*2,y+4*wide+high,wide,high,penSize,90,6
            Call Oval x+wide+high+pen,y+5*wide+2*high,wide,high,penSize,0,6
        Case 9
            Call Oval x+wide+high,y+2*high,wide,high,penSize,0,6
            Call Oval x+high,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+2*wide+high,y+2*wide-high,wide,high,penSize,90,6
            Call Oval x+wide+high,y+3*wide,wide,high,penSize,0,6
            Call Oval x+2*wide+high,y+4*wide+3*high/2,wide+3*high/2,high,penSize,90,6
    End Select
End SUB

SUB Oval centerX,centerY,wide,high,penSize,rotAngle,sides
    pi2=Atn(1)*8.0
    d2r=pi2/360.0
    interval=360.0/sides
    If interval<=0.0 Or interval>180.0 Then interval=1.0
    interval=d2r*interval
    rotAngle=d2r*rotAngle
    If penSize<1 Then penSize=1
    If rotAngle=0 Then
        x1=wide+centerX
        y1=centerY
        #g "Place ";x1;" ";y1
        For i=interval To pi2 STEP interval
            x2=Cos(i)*wide+centerX
            y2=Sin(i)*high+centerY
            #g "Goto ";x2;" ";y2
        Next i
    Else
        cs=Cos(rotAngle):sn=Sin(rotAngle)
        x1=cs*wide+centerX
        y1=sn*wide+centerY
        #g "Place ";x1;" ";y1
        For i=interval To pi2 STEP interval
            rotX=Cos(i)*wide
            rotY=Sin(i)*high
            x2=cs*rotX-sn*rotY+centerX
            y2=sn*rotX+cs*rotY+centerY
            #g "Goto ";x2;" ";y2
        Next i
    End If
End SUB

 
« Last Edit: Aug 14th, 2017, 10:06am by Rod » User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program ledclock.bas
« Reply #50 on: Aug 14th, 2017, 10:05am »

ledclock.bas part 2

Code:
Sub SuperEllipse centerX,centerY,wide,high,exponent,numSegments,penSize,rotAngle
    pi2=Atn(1)*8.0
    d2r=pi2/360.0
    If penSize<1 Or penSize>400 Then penSize=1
    #g "Size ";penSize
    If exponent<.15 Then exponent=.15
    If exponent>99 Then exponent=99
    If exponent=0 Then power=0 Else power=2/exponent-1
    If rotAngle>=360 Then rotAngle=rotAngle-Int(rotAngle/360)*360
    inc=360.0/numSegments*d2r
    rotAngle=d2r*rotAngle
    If rotAngle=0 Then
        x1=wide+centerX
        y1=centerY
        #g "Place ";x1;" ";y1
        limit=pi2+inc
        For theta=inc To limit STEP inc
            cosTheta=Cos(theta)
            sinTheta=Sin(theta)
            x2=wide*cosTheta*Abs(cosTheta)^power+centerX
            y2=high*sinTheta*Abs(sinTheta)^power+centerY
            #g "Goto ";x2;" ";y2
        Next theta
    Else
        cs=Cos(rotAngle)
        sn=Sin(rotAngle)
        rotX=wide
        x1=cs*rotX+centerX
        y1=sn*rotX+centerY
        #g "Place ";x1;" ";y1
        limit=pi2+inc
        For theta=inc To limit STEP inc
            cosTheta=Cos(theta)
            sinTheta=Sin(theta)
            rotX=cosTheta*wide*Abs(cosTheta)^power
            rotY=sinTheta*high*Abs(sinTheta)^power
            x2=cs*rotX-sn*rotY+centerX
            y2=sn*rotX+cs*rotY+centerY
            #g "Goto ";x2;" ";y2
        Next theta
    End If
End Sub

Function GetDC(hWnd)
    CallDLL #user32, "GetDC", hWnd As Long, GetDC As Long
End Function

Sub ReleaseDC hWnd, hDC
    CallDLL#user32,"ReleaseDC", hWnd As Long, hDC As Long, result As Long
End Sub

Sub SetBkMode hDC, bkndFlag
    CallDLL #gdi32, "SetBkMode", hDC As Long, bkndFlag As Long, RESULT As Long
End Sub

Sub text x,y,msg$
    #g "Place ";x;" ";y;";|";msg$
End Sub



 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program locate.bas
« Reply #51 on: Aug 14th, 2017, 10:18am »

locate.bas


Changed to a timer based pause rather than while wend to avoid [quit] not being found if close is clicked while we were in the sub.


Code:
    'locate.bas
    'This program demonstrates how to change the location
    'of a control in a window.
    nomainwin

    combobox #main.lb, array$(), [ok], 10, 10, 100, 150
    open "Locate control" for window as #main
    #main "trapclose [quit]"

    for x = 10 to 200 step 10

        gosub [pause]

        'relocate the combobox
        #main.lb "locate ";x; " ";x; " 100 150"

        'force the new location to take effect
        #main "refresh"

    next x
    wait

[pause]
    timer 100, [done]
    wait

    [done]
    timer 0
    return

[quit]
    'in case the timer was running when close was clicked
    timer 0
    close #main
    timer 0
    end

 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program mandala.bas
« Reply #52 on: Aug 14th, 2017, 1:06pm »

Mandala.bas


Jazzed up a bit, I'm liking it.


Code:

    'Plot a mandala with 20 vertices
    'then cycle its colors
    nomainwin

    dim verticesX(100)
    dim verticesY(100)
    verticesQty = 20
    diameter = DisplayHeight-100
    radius = int(diameter/2)
    angle = 360/verticesQty

    ' Open the graphics window
    open "Mandala" for graphics_fs_nsb as #mand
    #mand "trapclose [quit]"
    #mand "down ; fill black ; up"


    ' Create vector table
    for i = 1 to verticesQty

        ' each cycle place turtle in center of screen pointing up
        ' the drawing won't be seen since the pen is up but the
        ' coordinates will be recorded

        #mand "home"
        #mand "north"

        ' Turn turtle to next vector and 'go' there
        #mand "turn "; i * angle
        #mand "go "; radius

        ' Ask for turtle position in xy
        #mand "posxy vrtcX vrtcY"

        ' Add to table
        verticesX(i) = vrtcX
        verticesY(i) = vrtcY

    next i

    ' Draw - put the pen down
    #mand "down"

    [cycle]
    'discard the drawing memory each cycle
    #mand "discard"

    ' Draw each individual line in the mandala
    for n = 1 to verticesQty
        for m = n to verticesQty
            r=int(rnd(0)*200+56)
            g=int(rnd(0)*200+56)
            b=int(rnd(0)*200+56)
            #mand "color ";r;" ";g;" ";b
            #mand "line "; verticesX(n); " "; verticesY(n); " "; verticesX(m); " "; verticesY(m)
        next m
    next n

    'break out if the user wants
    scan

    'or do it again
    goto [cycle]



[quit]
    close #mand
    end

 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program mayhem.bas
« Reply #53 on: Aug 14th, 2017, 1:48pm »

mayhem.bas

A few tweaks, main one is to leave the shot track on display which I thinks gives it a little more appeal to a beginner, they can see what is going on. Changed input loop to wait.

The .bas is copyright so this is just a suggestion.

Code:
    'Mayhem!
    'A Liberty BASIC Game
    'Copyright 1995,2000 Carl Gundel and Steve Woodward

    'Mayhem is a game where two tanks shoot at each other in a ramdomly
    'generated landscape!   Each tank's gun is aimed by inputting an
    'angle from the horizon, and a number of pounds of TNT to propell a
    'shell with.

    'Note: There is nothing to force the players to
    'take turns while playing.


    'How to shoot
    '--------------------------------------------------------------------

    'Pick an angle from 1 to 90 degrees of the horizon and input it.
    'Then pick a quantity of pounds of TNT to use 1 - 20 (more or less)
    'and input that.  Then click on the fire button!

    'Now if you miss, give the other chap a shot at you!  And round you
    'go!!!


    'Modifying the game
    '--------------------------------------------------------------------

    'When you get bored of Mayhem, add features to make it interesting.
    'Try making it three players, or four!  Make the ground invisible
    'so that you have to hit it with a shell to 'feel' your way around it!
    'Add some cool sound effects or a dramatic musical score!
    'Try giving each player a limited number of shells, or a limited
    'quantity of TNT.  Or all of the above with a setup screen!  Use your
    'imagination, and then share your code with all of us!

    'Special thanks to Steve Woodward for inspiring me to write this game!

    dim terrain(500)

    nomainwin

    loadbmp "lefttank", "bmp\ltank.bmp"
    loadbmp "righttank", "bmp\rtank2.bmp"
    loadbmp "leftbang", "bmp\lbang.bmp"
    loadbmp "rightbang", "bmp\rbang.bmp"

    WindowWidth = 500
    WindowHeight = 440
    UpperLeftX = (DisplayWidth-WindowWidth)/2
    UpperLeftY = (DisplayHeight-WindowHeight)/2

    menu #mayhem, "&Game", "&New Game", [newGame], "&About Mayhem!", [aboutMayhem], "&Exit", [exit]
    statictext #mayhem.statictext1, "Angle", 22, 336, 40, 20
    textbox #mayhem.angleUsa, 70, 331, 100, 25
    statictext #mayhem.statictext3, "TNT", 22, 366, 26, 20
    textbox #mayhem.tntUsa, 70, 361, 45, 25
    button #mayhem, "Fire!", [fireUsa], UL, 120, 361
    statictext #mayhem.statictext2, "Angle", 322, 336, 40, 20
    textbox #mayhem.angleUssr, 370, 331, 100, 25
    statictext #mayhem.statictext4, "TNT", 322, 366, 26, 20
    textbox #mayhem.tntUssr, 370, 361, 45, 25
    button #mayhem, "Fire!", [fireUssr], UL, 420, 361
    graphicbox #mayhem.graphics, 0, 0, 494, 330
    open "Mayhem!" for window_nf as #mayhem
    print #mayhem.angleUsa, "!setfocus"
    print #mayhem, "trapclose [exit]"


[newGame]

    rate1 = rnd(1) / (rnd(1) * 20 + 10)
    rate2 = rnd(1) / (rnd(1) * 6 + 10)
    windspeed = int(rnd(1) * 50) - 25
    usaX = int(rnd(1) * 100) + 25
    ussrX = int(rnd(1) * 100) + 350

    #mayhem.graphics "cls ; fill cyan ; down ; color brown ; size 2"

    for x = 0 to 499 step 2
        holder1 = holder1 + rate1
        holder2 = holder2 + rate2
        holder3 = holder3 + sin(holder2) / 20
        y = 200 + int(sin(holder1) * 75) + int(cos(holder2) * 30) + int(cos(holder3) * 10)
        terrain(x) = y : terrain(x + 1) = y
        #mayhem.graphics "line "; x; " "; y; " "; x; " 410"
    next x

    #mayhem.graphics "drawbmp lefttank "; usaX - 16; " "; terrain(usaX) - 24;
    for x = usaX - 17 to usaX + 17 : terrain(x) = terrain(usaX) - 8 : next x

    #mayhem.graphics "drawbmp righttank "; ussrX - 16; " "; terrain(ussrX) - 24;
    for x = ussrX - 17 to ussrX + 17 : terrain(x) = terrain(ussrX) - 8 : next x

    #mayhem.graphics "place 10 15"

    #mayhem.graphics "color black ; backcolor cyan"
    if windspeed < 0 then #mayhem.graphics "\Wind <<"; abs(windspeed); "<<"
    if windspeed = 0 then #mayhem.graphics "\Wind <<0>>"
    if windspeed > 0 then #mayhem.graphics "\Wind >>"; windspeed; ">>"

    #mayhem.graphics "flush segId"


wait


[fireUsa]   'the USA fires its gun!
    #mayhem.angleUsa "!contents? angle"
    #mayhem.tntUsa "!contents? tnt"
    if tnt <= 1 then
        notice "What are you kidding?  Put more tnt in there unless you wanna blow yourself up!"
        wait
    end if
    direction = 1
    x = usaX
    y = terrain(x) - 16
    goto [trackShell]

[fireUssr]   'the USSR fires its gun!
    #mayhem.angleUssr "!contents? angle"
    #mayhem.tntUssr "!contents? tnt"
    if tnt <= 1 then
        notice "What are you kidding?  Put more tnt in there unless you wanna blow yourself up (how do you say this in Russian?)!"
        wait
    end if
    direction = -1
    x = ussrX
    y = terrain(x) - 16
    goto [trackShell]

[trackShell]
    live = 1
    explode = 0
    tnt = tnt * 100
    windEffect = windspeed / 50
    angleXform = angle / 180 * 3.14
    xVelocity = (cos(angleXform) * tnt + 0.001) * direction
    yVelocity = sin(angleXform) * tnt + 0.001
    adjust = 3 / yVelocity
    if abs(xVelocity) > yVelocity then adjust = 3 / xVelocity * direction
    xVelocity = xVelocity * adjust * 2
    yVelocity = yVelocity * adjust * 2
    lastX = 0 : lastY = 0
   ' #mayhem.graphics "rule xor"
    while live = 1
        gosub [waitIfNeeded]
        x = x + xVelocity + windEffect
        y = y - yVelocity
        yVelocity = yVelocity - (32 * adjust)
        #mayhem.graphics "place "; x; " "; y
        #mayhem.graphics "go 1"
        if lastX = 0 then [firstTimeUsa]
        #mayhem.graphics "place "; lastX; " "; lastY
        #mayhem.graphics "go 1"
      [firstTimeUsa]
        lastX = x : lastY = y
        if x < 1 or x > 499 then live = 0
        if live = 1 and y >= terrain(int(max(0,min(x,500)))) then live = 0 : explode = 1
    wend
    #mayhem.graphics "discard ; flush"

    explodeX = x
    explodeY = y
    gosub [explosion]
    if x >= usaX - 17 and x <= usaX + 17 then [explodeUsa]
    if x >= ussrX - 17 and x <= ussrX + 17 then [explodeUssr]
    wait




[waitIfNeeded]  'keep the game from running too fast on fast machines

    if tnt = 0 then tnt = 1
    newTime = time$("milliseconds")
    while newTime < oldTime + (30/(tnt/1000))
        newTime = time$("milliseconds")
    wend
    oldTime = newTime
    return

[explosion]   'Make an explosion at explodeX explodeY

    explodeRate = 2
    explodeSpeed = explodeRate * 100
    if hit = 0 then #mayhem.graphics "rule xor"
    #mayhem.graphics "size "; explodeRate
    #mayhem.graphics "place "; explodeX; " "; explodeY
    if hit = 1 then explodeSize = 42 else explodeSize = 18
    #mayhem.graphics "circle "; 6 - explodeRate
    for radius =  6 to explodeSize step explodeRate
        #mayhem.graphics "circle "; radius
        call pause
        #mayhem.graphics "circle "; radius - explodeRate
    next radius
    #mayhem.graphics "circle "; explodeSize
    #mayhem.graphics "rule over"
    #mayhem.graphics "discard"
    return


sub pause    'pause for a tenth of a second
    start = time$("ms")
    while start + 20 > time$("ms")
    wend
end sub


[explodeUsa]  'blow up the Usa tank

    #mayhem.graphics "drawbmp leftbang "; usaX - 16; " "; terrain(usaX) - 16
    #mayhem.graphics "delsegment "; segId
    now$ = time$() : while time$() = now$ : wend
    notice "USSR wins this round!"
    goto [newGame]


[explodeUssr]  'blow up the Ussr tank

    #mayhem.graphics "drawbmp rightbang "; ussrX - 16; " "; terrain(ussrX) - 16
    #mayhem.graphics "delsegment "; segId
    now$ = time$() : while time$() = now$ : wend
    notice "USA wins this round!"
    goto [newGame]


[aboutMayhem]  'Display an "About Mayhem!" dialog box

    WindowWidth = 336
    WindowHeight = 150
    statictext #main.statictext1, "Mayhem! is a game written in Liberty", 14, 16, 288, 20
    statictext #main.statictext2, "BASIC and is copyright Carl Gundel and", 14, 36, 304, 20
    statictext #main.statictext3, "Steve Woodward, 1995.", 14, 56, 168, 20
    button #main, "OK", [aboutOK], UL, 214, 76
    open "About Mayhem!" for dialog as #main
    print #main, "trapclose [aboutOK]"
    wait


[aboutOK]   'Perform action for the button named 'aboutOK'
    close #main
    wait



[exit]  'Quit Mayhem!
    confirm "Are you sure you want to exit?  We still have all this ammo!"; answer$
    if answer$ <> "yes" then wait
    close #mayhem
    end

 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program multiwin.bas
« Reply #54 on: Aug 14th, 2017, 1:57pm »

multiwin.bas


Prefilled the data so something is plotted moved window to centre screen


Code:

    'multiwin.bas  - A short example that manages more than one window.
    'Notice that the main dialog window closes the entire app and so
    'does not need the same kind of fancy handling as its two subwindows.
    nomainwin

    dim properties(10) 'use this to store global properties

    'set up global window sizing values
    UpperLeftX = (DisplayWidth-WindowWidth)/2
    UpperLeftY = 10
    WindowWidth = 304
    WindowHeight = 115

    call openBallisticDialog
    wait


[quit]
    call closeGraphWindow
    call closeTextWindow
    call closeBallisticDialog
    end

sub closeBallisticDialog
    close #ballistic
end sub

[plot]  'this code borrowed from the mayhem.bas game
    call openGraphWindow
    call openTextWindow
    x = 0
    y = groundZero()

    #ballistic.angle "!contents? angle"
    #ballistic.velocity "!contents? velocity"
    velocity = velocity * 100
    angleXform = angle / 180 * 3.14
    xVelocity = cos(angleXform) * velocity
    yVelocity = sin(angleXform) * velocity
    adjust = 3 / (yVelocity + 0.0001)
    if abs(xVelocity) > yVelocity then adjust = 3 / (xVelocity + 0.0001)
    xVelocity = xVelocity * adjust * 2
    yVelocity = yVelocity * adjust * 2
    while x < 300 and y <= groundZero()
        x = x + xVelocity
        y = y - yVelocity
        call plotTo x, y
        yVelocity = yVelocity - (32 * adjust)
    wend
    wait

sub plotTo x, y
    #graph "goto "; int(x); " "; int(y)
    #text x; ","; groundZero()-y
end sub

function groundZero()  'make a constant
    groundZero = 90
end function

sub openBallisticDialog
    statictext #ballistic, "Angle (0-89):", 8, 21, 70, 20
    textbox #ballistic.angle, 86, 16, 184, 25
    statictext #ballistic, "Velocity (0-10):", 8, 51, 70, 20
    textbox #ballistic.velocity, 86, 46, 100, 25
    button #ballistic.plot, "Plot!", [plot], UL, 222, 46, 50, 25
    open "Ballistic Plot" for dialog as #ballistic
    #ballistic "trapclose [quit]"
    #ballistic.angle "45"
    #ballistic.velocity "4"
end sub

sub openGraphWindow
    if isGraphOpen() = 0 then   'only open it if it isn't open
        UpperLeftY = 130
        open "Ballistic Plot" for graphics_nsb as #graph
        #graph "trapclose [closeGraph]"
        #graph "down"
        call graphIsOpen
    else
        'I could do something here if the window is open
    end if
    #graph "place 0 "; groundZero()
end sub

sub openTextWindow
    if isTextOpen() = 0 then   'only open it if it isn't open
        UpperLeftY = 250
        WindowHeight = 250
        open "Ballistic Report" for text as #text
        #text "!trapclose [closeText]";
        call textIsOpen
    else
        'I could do something here if the window is open
    end if
    #text "============Report starts============="
end sub

[closeGraph]
    call closeGraphWindow
    wait

sub closeGraphWindow
    if isGraphOpen() then
        close #graph
        call graphIsClosed
    end if
end sub

[closeText]
    call closeTextWindow
    wait

sub closeTextWindow
    if isTextOpen() then
        close #text
        call textIsClosed
    end if
end sub

sub graphIsOpen    'indicate that the graph window is open
    properties(0) = 1
end sub

sub graphIsClosed    'indicate that the graph window is closed
    properties(0) = 0
end sub

sub textIsOpen    'indicate that the text window is open
    properties(1) = 1
end sub

sub textIsClosed    'indicate that the text window is closed
    properties(1) = 0
end sub

function isGraphOpen()    'is the graph window open? return zero or non-zero
    isGraphOpen = properties(0)
end function

function isTextOpen()    'is the text window open? return zero or non-zero
    isTextOpen = properties(1)
end function

 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program newcolor.bas
« Reply #55 on: Aug 14th, 2017, 2:00pm »

newcolor.bas


Does not add anything delete?
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program password.bas
« Reply #56 on: Aug 14th, 2017, 2:50pm »

password.bas

A much improved version dispensing with the timer and simplifying the inkey$ handling. The textbox is also disabled.


Code:
    'PASSWORD EXAMPLE WITH A MASK
    'password protect your programs with this simple password screen
    'the password is masked with the asterisk you can change the mask
    'to what ever you want. You can also use the backspace key to delete
    'a charcter. You can use the enter key or press the Ok button after
    'you enter the password

    'the password in this example is "ok"
    nomainwin


    WindowWidth = 300
    WindowHeight= 150
    UpperLeftX = (DisplayWidth-WindowWidth)/2
    UpperLeftY = (DisplayHeight-WindowHeight)/2

    'hidden graphicbox is used to capture key input
    graphicbox #pass.gb, 0,0,0,0
    'textbox is used to show the masked input
    'the textbox is disabled to prevent input
    textbox #pass.tb, 15,20,260,25
    'ok button optional
    button #pass.default, "Ok", [ok],UL 105,60,70,25
    open "Enter Password" for window as #pass
    #pass "trapclose [quitpass]"
    #pass.tb "!disable"
    #pass.gb "setfocus"
    #pass.gb "when characterInput [letter]"
    wait


[letter]
    key$=Inkey$
    if len(key$)=1 then key=asc(key$) else key=0
    if key=_VK_BACK then b$=left$(b$,len(b$)-1)
    if key =_VK_RETURN then goto [ok]
    if key>=32 and key<=126 then b$ = b$ + chr$(key)
    mask$=""
    for x = 1 to len(b$)
        mask$=mask$+"*"
    next
    #pass.tb mask$
    #pass.gb "setfocus"
    wait

[quitpass]
    close #pass
    end

[ok]
    if b$="ok" then
        notice "Password ok"
    else
        notice "Password incorrect"
    end if
    close #pass
    end
 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program piano.bas
« Reply #57 on: Aug 14th, 2017, 3:04pm »

piano.bas


Couple of ulongs for the DC code and that was it.


Code:
    'piano6.bas - a cool piano that uses Windows' built-in MIDI synthesizer
    'plays one note at a time on channel 1 (channel 1 = 144)
    'allows selection from 128 MIDI voices
    '
    'this program uses a piano with one key more than earlier piano programs

    NoMainWin

[initVariables]
    note=0                  'will contain value for note
    BLACK=0                 'color value for black keys
    WHITE=hexdec("FFFFFF")  'color value for white keys
    Dim ins$(128)   'names of instruments

    'read instrument name data into array for combobox
    For vc = 0 to 127
        Read data$
        ins$(vc)=data$
    Next vc

    'combobox index is 1-based, instrument voices are 0-based
    instrum=1 'select first instrument voice
    voice=0   'voice 0 = instrum 1

    msg$="To play the piano, click the keys with your mouse " _
    +"or type on keyboard. Select a voice from the combobox."




    WindowWidth=640
    WindowHeight=240
    UpperLeftX=(DisplayWidth-WindowWidth)/2
    UpperLeftY=(DisplayHeight-WindowHeight)/2
    Button #p.default, "Close",[quit],UL,520,15,96,30
    Statictext #p, "Select Instrument",15,5,200,20
    Combobox #p.ins, ins$(,[instrument],15, 25, 220,400
    Graphicbox #p.g, 0, 70,638,100
    Statictext #p.vol, msg$,15,180,550,40
    Open "Electronic Piano" For Window_nf As #p

    LoadBmp "piano","bmp\piano6.bmp"

    #p.g   "down;drawbmp piano 0 0;flush"
    #p.g   "setfocus; when leftButtonDown [newNote]"
    #p.g   "when leftButtonUp [endNote]"
    #p.g   "when leftButtonMove [moveNote]"
    #p.g   "when characterInput [keyNote]"
    #p.ins "select Grand Piano"
    #p     "trapclose [quit]"

    Wnd=hWnd(#p.g)  'handle of graphicbox
    'get device context for graphicbox
    CallDLL #user32, "GetDC",_
        Wnd As ulong,  hDC As ulong

    'open midi device and obtain handle
    'midi functions return 0 if successful
    struct m, a$ As ptr
    CallDLL #winmm, "midiOutOpen",_
        m As struct,-1 As long,0 As long,_
        0 As long,0 As long,ret As long

    hMidiOut=m.a$.struct    'handle to midi device
    Wait

[quit]'stop note, close midi device, DLLs, window
    timer 0
    UnloadBmp "piano"
    gosub [stopPlay]   'stop all output
    CallDLL #winmm, "midiOutClose", hMidiOut As long,_
        ret As ulong

    CallDLL#user32,"ReleaseDC",_
        Wnd As ulong,hDC As ulong,result As long
    Close #p
    End


[instrument]'user selected an instrument voice
    #p.ins "selectionindex? instrum"
    #p.g   "setfocus"
    gosub [doChange]   'change voice
    Wait


[newNote] 'mouse clicked to start new note
    gosub [stopNote]   'stop previous note
    gosub [findNote]   'set new note value
    note=mnote         'set note to match piano key clicked by mouse
    gosub [playNewNote]'play new note
    Wait


[moveNote]'mouse moved while button was down
          'determine if it has moved to new note
          'and if it has, stop old note and sound new note
    gosub [findNote]         'set note value
    if mnote=note then wait  'mouse is on same key, do nothing
    gosub [stopNote]         'stop previous note
    note=mnote               'set note to match piano key clicked by mouse
    gosub [playNewNote]      'play new note
    Wait


[keyNote]   'a keyboard key was pressed
    gosub [stopNote]      'stop previous note
    gosub [findKeyNote]   'set new note value
    gosub [playNewNote]   'play new note
    timer 1000, [cutOff]  'to stop notes played by typing on keyboard
    wait


[cutOff]'stop note played by typing on keyboard
    gosub [stopNote]
    wait


[endNote]'stop note when mouse button is released
    gosub [stopNote]
    Wait


'GOSUBS:
[findKeyNote]'determine a note based on keyboard key pressed
    k = asc(Inkey$)
    select case
    case  (k>96) and (k<123)
        note=k-50   'lowercase letters
    case (k>64) and (k<91)
        note=k-18   'uppercase letters
    case else
        note=48     'non-alpha key
    end select
    RETURN


[playNewNote]'play new note:
    gosub [stopNote]
    event=144   'event 144 = play on channel 1
    low=(note*256)+event
    velocity=127
    hi=velocity*256*256
    dwMsg=low+hi
    CallDLL #winmm, "midiOutShortMsg",hMidiOut As ulong,_
        dwMsg As ulong, ret As ulong
    RETURN


[stopNote]'stop note from playing
    timer 0
    event=144    'event 144 = play on channel 1
    low=(note*256)+event
    hiZero=0     'stop note from sounding by setting velocity to 0
    dwMsg=low+hiZero
    CallDLL #winmm, "midiOutShortMsg",hMidiOut As ulong,_
        dwMsg As ulong, ret As ulong
    #p.g "setfocus; when characterInput [keyNote]"
    RETURN


[stopPlay]'stop all notes from playing
    event=128    'event 128 = stop play
    low=(note*256)+event
    dwMsg=low+hi
    CallDLL #winmm, "midiOutShortMsg",hMidiOut As ulong,_
        dwMsg As ulong, ret As ulong
    timer 0
    RETURN


[doChange]'signal a voice change:
    event=192  'event 192 = change
    voice=instrum-1
    velocity=127
    low=(voice*256)+event
    hi=velocity*256*256
    dwMsg=low+hi
    CallDLL #winmm, "midiOutShortMsg",hMidiOut As ulong,_
        dwMsg As ulong, ret As ulong
    RETURN


[findNote]'determine piano key pressed by mouse to set note
          'note value will be in mnote
    MX=MouseX:MY=MouseY

    CallDLL #gdi32, "GetPixel",hDC As ulong,_
        MX As long,MY As long,keyColor As long

    If keyColor=BLACK Then  'black keys
        If MX<=54  Then mnote = 49 : RETURN  'c#
        If MX<=97  Then mnote = 51 : RETURN  'd#
        If MX<=183 Then mnote = 54 : RETURN  'f#
        If MX<=226 Then mnote = 56 : RETURN  'g#
        If MX<=266 Then mnote = 58 : RETURN  'a#
        If MX<=354 Then mnote = 61 : RETURN  'c#
        If MX<=397 Then mnote = 63 : RETURN  'd#
        If MX<=483 Then mnote = 66 : RETURN  'f#
        If MX<=527 Then mnote = 68 : RETURN  'g#
        If MX<=566 Then mnote = 70 : RETURN  'a#
        return
    end if
    if keyColor=WHITE then  'white keys
        If MX<=43  Then mnote = 48 : RETURN  'c
        If MX<=86  Then mnote = 50 : RETURN  'd
        If MX<=129 Then mnote = 52 : RETURN  'e
        If MX<=172 Then mnote = 53 : RETURN  'f
        If MX<=215 Then mnote = 55 : RETURN  'g
        If MX<=258 Then mnote = 57 : RETURN  'a
        If MX<=300 Then mnote = 59 : RETURN  'b
        If MX<=343 Then mnote = 60 : RETURN  'c
        If MX<=386 Then mnote = 62 : RETURN  'd
        If MX<=429 Then mnote = 64 : RETURN  'e
        If MX<=472 Then mnote = 65 : RETURN  'f
        If MX<=515 Then mnote = 67 : RETURN  'g
        If MX<=558 Then mnote = 69 : RETURN  'a
        If MX<=600 Then mnote = 71 : RETURN  'b
        If MX<=638 Then mnote = 72 : RETURN  'c
        return
   End If
   RETURN


'list of 128 voices, in order of their MIDI indexes
Data "Grand Piano","Bright Grand","Electric Grand","Honky Tonk"
Data "Rhodes","Chorus Piano","Harpsichord","Clavinet"
Data "Celesta","Glockenspiel","Music Box","Vibraphone"
Data "Marimba","Xylophone","Tubular Bells","Dulcimer"
Data "Hammond Organ","Percussion Organ","Rock Organ"
Data "Church Organ","Reed Organ","Accordian","Harmonica"
Data "Tango Accordian","Accoustic Nylon Guitar"
Data "Accoustic Steel Guitar","Electric Jazz Guitar"
Data "Electric Clean Guitar","Electric Mute Guitar"
Data "Overdrive Guitar","Distorted Guitar","Guitar Harmonic"
Data "Accoustic Bass","Electric Bass Finger","Electric Bass Pick"
Data "Fretless Bass","Slap Bass One","Slap Bass Two"
Data "Synth Bass One","Synth Bass Two","Violin","Viola","Cello"
Data "Contrabass","Tremolo Strings","Pizzicato Strings"
Data "Orchestra Harp","Timpani","String Ensemble One"
Data "String Ensemble Two","Synth Strings One","Synth Strings Two"
Data "Choir Ahhs","Voice Oohs","Synth Voice","Orchestra Hit"
Data "Trumpet","Trombone","Tuba","Mute Trumpet","French Horn"
Data "Brass Section","Synth Brass One","Synth Brass Two"
Data "Soprano Sax","Alto Sax","Tenor Sax","Bari Sax","Oboe"
Data "English Horn","Bassoon","Clarinet","Piccolo","Flute"
Data "Recorder","Pan Flute","Bottle Blow","Shakuhachi","Whistle"
Data "Ocarina","Square Wave","Sawtooth","Caliope","Chiff Lead"
Data "Charang","Solo Synth VX","Brite Saw","Brass and Lead"
Data "Fantasia Pad","Warm Pad","Poly Synth Pad","Space Vox Pad"
Data "Bowd Glas Pad","Metal Pad","Halo Pad","Sweep Pad"
Data "Ice Rain","Sound Track","Crystal","Atmosphere","Brightness"
Data "Goblin","Echo Drops","Star Theme","Sitar","Banjo","Shamisen"
Data "Koto","Kalimba","Bagpipe","Fiddle","Shanai"
Data "Tinkle Bell","Agogo","Steel Drums","Wood Block","Taiko Drum"
Data "Melodic Tom","Synth Drum","Rev Cymbal"
Data "Guitar Fret Noise","Breath Noise","Sea Shore","Bird Tweet"
Data "Phone Ring","Helicopter","Applause","Gunshot"



 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program pie.bas
« Reply #58 on: Aug 15th, 2017, 04:27am »

pie.bas

Simple tidy

Code:
    'Draw some pie slices
    nomainwin

    open "pie" for graphics_nsb as #1
    #1 "trapclose [quit]"

    #1 "home ; down"
    #1 "backcolor red"
    #1 "piefilled 100 100 315 -315"
    #1 "north ; turn 67 ; up ; go 20 ; down"
    #1 "backcolor yellow"
    #1 "pieFilled 100 100 315 45"
    #1 "backcolor white"
    #1 "place 105 100 ;\My slice of pie"
    #1 "flush"
    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: Sample Program player.bas
« Reply #59 on: Aug 15th, 2017, 04:34am »

player.bas


Unchanged


Code:

    'Simple wave file player
    'You must have sound support installed to
    'use this player!

    template$ = "*.wav"

[loop]

    filedialog "Pick a *.WAV file", template$, w$
    if w$ = "" then [quit]
    playwave w$, asynch

    'get the path and make it the default
    while right$(w$, 1) <> "\"
        w$ = left$(w$, len(w$) - 1)
    wend
    template$ = w$ + "*.wav"

    goto [loop]

[quit]

    end
 
User IP Logged

Pages: 1 2 3 4 5 6  7 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