The QBasic / QB64 Discussion Forum      Other Subforums, Links and Downloads
 
 

 Return to Index  

http://www.rain.org/~mkummel/tbvault.html.

November 17 2011 at 10:00 PM
Anonymous  (no login)


Response to http://www.rubbermallet.org/software.html

 
'EGG.BAS v.03
'June 1997 by Marc Kummel aka Treebeard.
'Contact mkummel@rain.org, http://www.rain.org/~mkummel/

'New program frame based on SBx.BAS
'1 oct 1994

'****************************************************************************

'global
CONST ver = "Egg .03"
CONST debug = 1

'$INCLUDE: 'npsup.bi'

'local
DECLARE SUB EggDraw ()
DECLARE SUB EggDefault (flag%)
DECLARE SUB FileMenu ()
DECLARE SUB Info ()
DECLARE SUB Load (status%)
DECLARE SUB MainMenu ()
DECLARE SUB MainInit ()
DECLARE SUB MakeScreen (flag%)
DECLARE SUB MakeTopLine ()
DECLARE SUB Save (status%)
DECLARE SUB Shutdown ()

'first execute
IF debug THEN STACK 5000 ELSE STACK 10000
MainInit
MainMenu
END

SUB EggDefault (flag%)
SHARED lstring!, nail!, leftloops%, rightloops%, lerror!
SHARED xwindow!, ywindow!, showstring%, stepsize!, showstat%

IF flag% THEN 'true parameters:
lstring! = 34! 'length of string
nail! = 5! 'origin to nail (distance between nails=2c)
leftloops% = 3 'loops on left nail
rightloops% = 2 'loops on right nail

ELSE 'null parameters
lstring! = 10!
nail! = 0!
leftloops% = 1
rightloops% = 1
END IF

xwindow! = 15! 'screen window, adjusted for aspect
ywindow! = 10!
lerror! = .01 'iteration error limit
showstring% = false
showstat% = false
stepsize! = .005 'angle step

END SUB

SUB EggDraw
SHARED bot$
SHARED lstring!, nail!, leftloops%, rightloops%, lerror!
SHARED xwindow!, ywindow!, showstring%, stepsize!, showstat%
STATIC initflag%

IF lstring! <= (leftloops% + rightloops%) * nail! THEN
ErrorMsg "Your string is too short!"
EXIT SUB
END IF
BottomMsg "working...", false

sx% = 1
sy% = ytext%(3) + 2
ex% = cxmax - cwide - 2
ey% = ytext%(23) - 5
ywindow! = xwindow! * (ey% - sy%) / (ex% - sx%)
nailcross! = .15

IF showstat% THEN
WindowMenu
MenuTitle "Stats:"
MenuClear
TextColor black
cPrint "center angle√ł...........", 24, 4, nada, nada
cPrint "left nail distance......", 25, 4, nada, nada
cPrint "right nail distance.....", 26, 4, nada, nada
n$ = "<" + LTRIM$(STR$(leftloops%)) + "L + " + LTRIM$(STR$(rightloops%)) + "R>"
n$ = n$ + STRING$(24 - LEN(n$), ".")
cPrint n$, 27, 4, nada, nada
cPrint "iterations..............", 28, 4, nada, nada
END IF

MouseHide
VIEW
VIEW (sx%, sy%)-(ex%, ey%), white
WINDOW (-xwindow!, -ywindow!)-(xwindow!, ywindow!)

FOR n! = 0 TO ywindow!
LINE (-xwindow!, n!)-(xwindow!, n!), lightblue, , &HAAAA
LINE (-xwindow!, -n!)-(xwindow!, -n!), lightblue, , &HAAAA
NEXT n!
LINE (-xwindow!, 0)-(xwindow!, 0), hiwhite, , &HAAAA

FOR n! = 0 TO xwindow!
LINE (n!, -ywindow!)-(n!, ywindow!), lightblue, , &HAAAA
LINE (-n!, -ywindow!)-(-n!, ywindow!), lightblue, , &HAAAA
NEXT n!
LINE (0, -ywindow!)-(0, ywindow!), hiwhite, , &HAAAA

COLOR black
GOSUB CrossNails

'a bit of algebra to find first point:
' n=nail distance
' s=string length
' l=left loops
' r=right loops
'
' -n---------------------| ld=left distance= x-(-n)=x+n
' +n----| rd=right distance= x-n
' -+-------0-------+-----X x=coordinate to find
'
' (l*ld) + (r*rd) = s
' l*(x+n) + r*(x-n) = s
' l*x + l*n + r*x - r*n = s
' (l+r)*x + (l-r)*n = s
' (l+r)*x = s - (l-r)*n
' x = [s - (l-r)*n] / (l+r)

oy! = 0
ox! = (lstring! - (leftloops% - rightloops%) * nail!) / (leftloops% + rightloops%)
PSET (ox!, oy!)

'use successive approximations to find the rest
approx! = nail! 'first approximation
delta! = .003 'change per pass
ll! = leftloops%
rl! = rightloops%
limit! = (ll! + rl!) * lerror! 'allowable error

IF NOT initflag% THEN
showstring% = true: quit% = true
ELSE
quit% = NOT showstring%
END IF

DO
FOR theta! = 0 TO 2 * pi STEP stepsize!
sintheta! = SIN(theta!)
costheta! = COS(theta!)

cnt& = 1&
DO
y! = approx! * sintheta!
x! = approx! * costheta!
d! = ll! * SQR((x! + nail!) * (x! + nail!) + y! * y!) + rl! * SQR((x! - nail!) * (x! - nail!) + y! * y!)
IF ABS(d! - lstring!) < limit! THEN
EXIT DO
ELSEIF d! > lstring! THEN
approx! = approx! - delta!
ELSE
approx! = approx! + delta!
END IF
cnt& = cnt& + 1&

LOOP

IF showstring% THEN
LINE (-nail!, 0)-(ox!, oy!), hiwhite
LINE (nail!, 0)-(ox!, oy!), hiwhite
LINE (ox!, oy!)-(x!, y!), yellow
LINE (-nail!, 0)-(x!, y!), black
LINE (nail!, 0)-(x!, y!), black
GOSUB CrossNails
ELSE
LINE (ox!, oy!)-(x!, y!)
END IF
ox! = x!: oy! = y!

IF showstat% THEN
WINDOW: VIEW
cPrintTab STR$(180! * theta! / pi), 24, 30, 40, black, white
ln! = SQR((x! + nail!) * (x! + nail!) + y! * y!)
rn! = SQR((x! - nail!) * (x! - nail!) + y! * y!)
cPrintTab STR$(ln!), 25, 30, 40, black, white
cPrintTab STR$(rn!), 26, 30, 40, black, white
cPrintTab STR$(ll! * ln! + rl! * rn!), 27, 30, 40, black, white
cPrintTab STR$(cnt&), 28, 30, 35, black, white
VIEW (sx%, sy%)-(ex%, ey%)
WINDOW (-xwindow!, -ywindow!)-(xwindow!, ywindow!)
END IF

IF EventHappens% THEN
SoundBip
IF p1% <> esckey THEN GetEvent flag%
IF p1% = esckey THEN quit% = true: EXIT FOR
END IF

NEXT theta!
LOOP UNTIL quit%

IF showstring% THEN
LINE (-nail!, 0)-(x!, y!), hiwhite
LINE (nail!, 0)-(x!, y!), hiwhite
GOSUB CrossNails
END IF

IF NOT initflag% THEN initflag% = true: showstring% = false

WINDOW
VIEW
IF showstat% THEN WindowClose: MenuTitle "Options:"
MouseShow
BottomMsg bot$, true
EXIT SUB

CrossNails:
LINE (-nail!, nailcross!)-(-nail!, -nailcross!)
LINE (-nail! - nailcross!, 0)-(-nail! + nailcross!, 0)
LINE (nail!, nailcross!)-(nail!, -nailcross!)
LINE (nail! - nailcross!, 0)-(nail! + nailcross!, 0)
RETURN

END SUB

SUB FileMenu
SHARED bot$

ShowTag "+File"
oldbot$ = bot$
bot$ = "Load Save Info Dos Quit"
opt$ = "LSIDQ"
BottomMsg bot$, true

DO
GetEvent flag%
IF flag% = mouseevent THEN
MouseUp
IF NOT BottomCheck%(opt$) THEN p1% = false
END IF

SELECT CASE Uppercase%(p1%)
CASE ASC("L"): Load status%: EXIT DO
CASE ASC("S"): Save status%: EXIT DO
CASE ASC("I"): Info
CASE ASC("Q"): Shutdown: END
CASE esckey: EXIT DO
CASE ELSE: SoundBop
END SELECT
LOOP

ShowTag "-"
bot$ = oldbot$
BottomMsg bot$, true
END SUB

SUB Info
SHARED bot$, startdir$, tmppath$

ShowTag "+Info"
oldbot$ = bot$
bot$ = "About"
opt$ = "A"
WindowScreen
ClearWindow
BottomMsg bot$, true
TextColor black
row% = 3: col% = xtext%(2): coltab% = xtext%(20)

byte$ = " bytes"
m$ = "heap size": n$ = STR$(SETMEM(0)) + byte$: GOSUB InfoLine
m$ = "free memory": n$ = STR$(FRE(-1)) + byte$: GOSUB InfoLine
m$ = "free DGroup": n$ = STR$(STACK) + byte$: GOSUB InfoLine
m$ = "free stack": n$ = STR$(FRE(-2)) + byte$: GOSUB InfoLine
reg.ax = &H3000
Interrupt &H21, reg, reg
m$ = "DOS version": n$ = RTRIM$(STR$(reg.ax AND 255)) + "." + LTRIM$(STR$(reg.ax \ 256)): GOSUB InfoLine

EMSInfo free&, total&, n%, pg%, nextfree%, handles%, pages%
m$ = "EMS version": n$ = STR$(n% \ 16) + "." + LTRIM$(STR$(n% AND &HF)): GOSUB InfoLine
m$ = "EMS pageframe": n$ = HEX$(pg%) + "h": GOSUB InfoLine
m$ = "EMS total": n$ = STR$(total&) + "k" + byte$: GOSUB InfoLine
m$ = "EMS free": n$ = STR$(free&) + "k" + byte$: GOSUB InfoLine
m$ = "EMS in use": n$ = STR$(total& - free&) + "k" + byte$: GOSUB InfoLine
m$ = "EMS pages": n$ = STR$(pages%): GOSUB InfoLine
m$ = "EMS handles used": n$ = STR$(handles%): GOSUB InfoLine
m$ = "EMS next handle": n$ = STR$(nextfree%): GOSUB InfoLine

m$ = "current dir": n$ = CURDIR$: GOSUB InfoLine
m$ = "start dir": n$ = startdir$: GOSUB InfoLine
m$ = "temp path": n$ = tmppath$: GOSUB InfoLine

MouseShow
DO
GetEvent flag%
IF flag% = mouseevent THEN
MouseUp
IF NOT BottomCheck%(opt$) THEN p1% = false
END IF

SELECT CASE Uppercase%(p1%)
CASE ASC("A"): SoundBip
CASE esckey: EXIT DO
CASE ELSE: SoundBop
END SELECT
LOOP

WindowClose
ShowTag "-"
bot$ = oldbot$
BottomMsg bot$, true
MouseShow
EXIT SUB

InfoLine:
OutText col%, ytext%(row%) + 4, m$
OutText coltab%, ytext%(row%) + 4, "= " + LTRIM$(n$)
row% = row% + 1
RETURN

END SUB

SUB Load (status%)
SHARED datapath$, datafile$

WindowScreen
ShowTag "+Load"
file$ = LoadFileName$("*.*", datapath$)

status% = 0
IF LEN(file$) = 0 THEN 'no file selected
status% = 1
ELSEIF LEN(DIR$(file$)) = 0 THEN 'file not found
status% = 2
END IF

'Load error, bail out
IF status% THEN
ShowTag "-"
WindowClose
EXIT SUB
END IF

'Load OK, take action
datafile$ = file$
ShowTag "-"
WindowKill
MakeScreen true

END SUB

SUB MainInit
SHARED invbuf%()
SHARED version$, startdir$, tmppath$
SHARED datapath$, datafile$

ON LOCAL ERROR GOTO FatalError

'global
REDIM onoff$(true TO false)
onoff$(true) = "on": onoff$(false) = "off"
esc$ = CHR$(esckey)
null$ = ""
version$ = ver

REDIM bit%(15)
bit%(0) = 1: bit%(15) = &H8000
FOR i% = 1 TO 14: bit%(i%) = bit%(i% - 1) * 2: NEXT i%

REDIM xtext%(1 TO 80), ytext%(1 TO 30)
n% = 0: FOR i% = 1 TO 80: xtext%(i%) = n%: n% = n% + cwide: NEXT i%
n% = 0: FOR i% = 1 TO 30: ytext%(i%) = n%: n% = n% + chigh: NEXT i%

startdir$ = CURDIR$
in$ = ENVIRON$("TEMP")
IF LEN(in$) THEN tmppath$ = in$ ELSE tmppath$ = CURDIR$
IF RIGHT$(tmppath$, 1) <> "\" THEN tmppath$ = tmppath$ + "\"
tmppath$ = UCASE$(tmppath$)

InitSupport
REDIM pw$(12)
REDIM winstk%(20, 2)
wsp% = nada

REDIM invbuf%(3000)
FOR i% = 2 TO 3000: invbuf%(i%) = &HFFFF: NEXT i%

'local
datapath$ = startdir$
datafile$ = null$

'video
n$ = "VGA graphics required!"
SCREEN 12

'fonts
LoadOneFont "VGAOEM.FON", 1, n%
IF n% THEN n$ = "Can't load VGAOEM.FON font! Error" + STR$(n%): GOTO FatalError

'mouse
MouseInit n%
IF n% = false THEN n$ = "Mouse driver required!": GOTO FatalError
MousePickShape arrow

'DOS

'EMS
IF NOT EMSInit% THEN n$ = "EMS not available!": GOTO FatalError

'Init application variables
EggDefault false

MouseShow
EXIT SUB

FatalError:
SCREEN 0
PRINT "Fatal error!"
PRINT n$
END

END SUB

SUB MainMenu
SHARED bot$
SHARED lstring!, nail!, leftloops%, rightloops%, lerror!
SHARED xwindow!, ywindow!, showstring%, stepsize!, showstat%

bot$ = "Egg Defaults File"
opt$ = "EDF"
MakeScreen true
SoundBip

DO
pw$(0) = "Options:"
pw$(1) = mReal$("length of string", lstring!)
pw$(2) = mReal$("distance to nail", nail!)
pw$(3) = mInt$("left nail loops", leftloops%)
pw$(4) = mInt$("right nail loops", rightloops%)
pw$(5) = mReal$("window size", xwindow!)
pw$(6) = mReal$("step size", stepsize!)
pw$(7) = mReal$("iteration error", lerror!)
pw$(8) = mOn$("show string", showstring%)
pw$(9) = mOn$("show stats", showstat%)
pw$(10) = null$

in% = false: Menu in%, opt$
DO
Menu in%, opt$
SELECT CASE in%
CASE 1: GetRealRange lstring!, 0, 10000
CASE 2: GetRealRange nail!, 0, 10000
CASE 3: GetIntRange leftloops%, 0, 1000
CASE 4: GetIntRange rightloops%, 0, 1000
CASE 5: GetRealRange xwindow!, 0, 10000
CASE 6: GetRealRange stepsize!, 0, 1
CASE 7: GetRealRange lerror!, 0, 1
CASE 8: BumpOn showstring%
CASE 9: BumpOn showstat%
CASE keyevent
SELECT CASE p1%
CASE spacekey, ASC("E"): EggDraw
CASE ASC("D"): EggDefault false: EXIT DO
CASE ASC("Z"): EggDefault true: EXIT DO
CASE ASC("F"): FileMenu: EXIT DO
CASE esckey: EXIT DO
CASE ELSE: SoundBop
END SELECT
CASE false: SoundBop: EXIT DO
END SELECT
LOOP
LOOP

END SUB

SUB MakeScreen (flag%)
SHARED bot$

IF flag% THEN
sx% = 0
sy% = ytext%(3) + 1
ex% = cxmax - cwide - 1
ey% = ytext%(23) - 4
MouseHide
LINE (sx%, sy%)-(ex%, ey%), white, BF
ButtonOutline sx%, sy%, ex% - sx%, ey% - sy%, false
sy% = ytext%(24) - 2
LINE (sx%, ey% + 1)-(ex%, ey% + 1), black
LINE (sx%, sy%)-(ex%, sy%), black
MouseShow
END IF

MakeTopLine
ShowTag null$
StatLine null$
MenuTitle null$
BottomMsg bot$, true
SliderMake 80, 3, bottomline - 1
MenuClear
EggDraw
MouseShow
END SUB

SUB MakeTopLine
SHARED datafile$
topline$ = SPACE$(80)

'center field
IF LEN(datafile$) THEN n$ = datafile$ ELSE n$ = "<untitled>"
n% = 41 - LEN(n$) \ 2: IF n% < 20 THEN n% = 20
MID$(topline$, n%) = n$

'right field
n$ = null$
MID$(topline$, 80 - LEN(n$)) = n$
cPrint topline$, 1, 1, hiwhite, blue
LINE (0, chigh - 1)-(639, chigh - 1), black

END SUB

SUB Save (status%)
SHARED datapath$, datafile$

ShowTag "+Save"
oldbot$ = bot$
WindowScreen

path$ = datapath$
name$ = datafile$
IF LEN(name$) THEN
FOR i% = LEN(name$) TO 1 STEP -1
IF INSTR("\:", MID$(name$, i%, 1)) THEN i% = i% + 1: EXIT FOR
NEXT i%
name$ = MID$(name$, i%)
END IF
IF INSTR(name$, ".") = 0 THEN name$ = name$ + ".DAT"
file$ = SaveFileName$(name$, "DAT", path$)
IF LEN(file$) THEN GOSUB SaveIt
ShowTag "-"
bot$ = oldbot$
WindowClose
EXIT SUB

SaveIt:
datafile$ = file$
datapath$ = path$
MakeTopLine
RETURN

END SUB

SUB Shutdown
SHARED startdir$, tmppath$
BottomMsg "Shutting down...", false
EMSKillAll
CHDIR startdir$
SCREEN 0
MouseInit n%
END SUB


 
 Respond to this message   
Response TitleAuthor and Date
no working (View Thread)Anonymous on Dec 2
   qbasicAnonymous on Dec 2
 Copyright © 1999-2014 Network54. All rights reserved.   Terms of Use   Privacy Statement  

Newbies usually go to www.qbasic.com and click on The QBasic Forum
Forum regulars have their own ways, which include The QBasic Community Forums