'EGG.BAS v.03
'June 1997 by Marc Kummel aka Treebeard.
'Contact
[email protected], 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