BCX Console Demonstration Program s152.bas
|
MACRO MaxFlights = 100
TYPE FL
Depart [20] AS CHAR
Arrival [20] AS CHAR
Distance AS INTEGER
Skip AS INTEGER
END TYPE
TYPE STACK
Depart[20] AS CHAR
Arrival[20] AS CHAR
Distance AS INTEGER
END TYPE
GLOBAL Flight[MaxFlights] AS FL
GLOBAL Bt_Stack[MaxFlights] AS STACK
GLOBAL Solution[MaxFlights] AS STACK
GLOBAL F_pos AS INTEGER
GLOBAL Find_pos AS INTEGER
GLOBAL tos AS INTEGER
GLOBAL stos AS INTEGER
GLOBAL start$
GLOBAL end$
GLOBAL gdist AS INTEGER
GLOBAL c1$
GLOBAL c2$
GLOBAL c3$
GLOBAL Use_Method
GLOBAL RouteTest
GLOBAL dd
GLOBAL tt
MACRO Depth = 0
MACRO Width = 1
MACRO Path = 2
MACRO Node = 3
MACRO Optimal = 4
PRINT "From ";
INPUT start$
PRINT "to ";
INPUT end$
'start$ = "New York"
'end$ = "Los Angeles"
'start$ = "Calgary"
'end$ = "Houston"
CALL Setup
dd = Find(start$, end$)
IF dd THEN
PRINT "Direct Route, Distance is "; dd
getchar()
END = 0
END IF
CALL Setup
PRINT
PRINT "Search by Depth"
Use_Method = Depth
IsFlight(start$, end$)
CALL Setup
PRINT
PRINT "Search by Width"
Use_Method = Width
IsFlight(start$, end$)
CALL Setup
PRINT
PRINT "Search by Path Removal"
Use_Method = Path
DO
RouteTest = IsFlight(start$, end$)
tos = 0
LOOP WHILE RouteTest > 0
CALL Setup
PRINT
PRINT "Search by Node Removal"
Use_Method = Node
DO
RouteTest = IsFlight(start$, end$)
CALL ClearMarkers
IF tos > 0 THEN
CALL Pop(c2$, c3$, &gdist)
CALL Pop(c1$, c3$, &gdist)
CALL Retract(c1$, c2$)
tos = 0
END IF
LOOP WHILE RouteTest > 0
CALL Setup
Use_Method = Optimal
PRINT
PRINT "Optimal Search"
RouteTest = IsFlight(start$, end$)
tt = 0
dd = 0
WHILE tt < stos
PRINT Solution[tt].Depart$; " to ";
dd += Solution[tt].Distance
tt++
WEND
PRINT end$
PRINT "Distance is "; dd
KEYPRESS
END = 0
SUB Setup
F_pos = 0
tos = 0
stos = 0
Find_pos = 0
Assert_Flight("New York", "Chicago", 1000)
Assert_Flight("Chicago", "New York", 1000)
Assert_Flight("New York", "Urbana", 1200)
Assert_Flight("Urbana", "New York", 1200)
Assert_Flight("Chicago", "Denver", 1000)
Assert_Flight("Denver", "Chicago", 1000)
Assert_Flight("Chicago", "Urbana", 400)
Assert_Flight("Urbana", "Chicago", 400)
Assert_Flight("Urbana", "Houston", 900)
Assert_Flight("Houston", "Urbana", 900)
Assert_Flight("New York", "Toronto", 800)
Assert_Flight("Toronto", "New York", 800)
Assert_Flight("New York", "Denver", 1900)
Assert_Flight("Denver", "New York", 1900)
Assert_Flight("Toronto", "Calgary", 1500)
Assert_Flight("Calgary", "Toronto", 1500)
Assert_Flight("Toronto", "Los Angeles", 1800)
Assert_Flight("Los Angeles", "Toronto", 1800)
Assert_Flight("Toronto", "Chicago", 500)
Assert_Flight("Chicago", "Toronto", 500)
Assert_Flight("Denver", "Urbana", 1000)
Assert_Flight("Urbana", "Denver", 1000)
Assert_Flight("Denver", "Houston", 1500)
Assert_Flight("Houston", "Denver", 1500)
Assert_Flight("Houston", "Los Angeles", 1500)
Assert_Flight("Los Angeles", "Houston", 1500)
Assert_Flight("Denver", "Los Angeles", 1000)
Assert_Flight("Los Angeles", "Denver", 1000)
END SUB
SUB Assert_Flight (frm$, dst$, dist AS INTEGER)
IF F_pos < MaxFlights THEN
Flight[F_pos].Depart$ = frm$
Flight[F_pos].Arrival$ = dst$
Flight[F_pos].Distance = dist
Flight[F_pos].Skip = 0
F_pos++
ELSE
PRINT "Flight database full"
END IF
END SUB
FUNCTION Match (frm$, dst$)
LOCAL t
WHILE t < F_pos
IF Flight[t].Depart$ = frm$ AND Flight[t].Arrival$ = dst$ THEN
FUNCTION = Flight[t].Distance
END IF
t++
WEND
FUNCTION = 0
END FUNCTION
FUNCTION BeenTo (where$)
LOCAL t
WHILE t < tos
IF Bt_Stack[t].Depart$ = where$ THEN
FUNCTION = 1
END IF
t++
WEND
FUNCTION = 0
END FUNCTION
FUNCTION Find (frm$, anywhere$)
Find_pos = 0
WHILE Find_pos < F_pos
IF Flight[Find_pos].Depart$ = frm$ AND Flight[Find_pos].Skip = 0 THEN
IF BeenTo(Flight[Find_pos].Arrival) = 0 THEN
anywhere$ = Flight[Find_pos].Arrival
Flight[Find_pos].Skip = 1 + tos
FUNCTION = Flight[Find_pos].Distance
END IF
END IF
Find_pos++
WEND
FUNCTION = 0
END FUNCTION
SUB Push (frm$, dst$, dist AS INTEGER)
IF tos < MaxFlights THEN
Bt_Stack[tos].Depart$ = frm$
Bt_Stack[tos].Arrival$ = dst$
Bt_Stack[tos].Distance = dist
tos++
ELSE
PRINT "Stack full"
END IF
END SUB
SUB Pop (frm$, dst$, dist AS INTEGER PTR)
IF tos > 0 THEN
tos--
frm$ = Bt_Stack[tos].Depart
dst$ = Bt_Stack[tos].Arrival
*dist = Bt_Stack[tos].Distance
ELSE
PRINT "Stack underflow"
END IF
END SUB
SUB Spush (frm$, dst$, dist AS INTEGER)
IF stos < MaxFlights THEN
Solution[stos].Depart$ = frm$
Solution[stos].Arrival$ = dst$
Solution[stos].Distance = dist
stos++
ELSE
PRINT "Solution Stack full"
END IF
END SUB
SUB ClearFar ()
LOCAL ts
ts = tos + 1
Find_pos = 0
WHILE Find_pos < F_pos
IF Flight[Find_pos].Skip > ts THEN
Flight[Find_pos].Skip = 0
END IF
Find_pos++
WEND
END SUB
SUB ClearWidth (frm$, anywhere$)
LOCAL ts
Find_pos = 0
WHILE Find_pos < F_pos
IF Flight[Find_pos].Depart$ = frm$ AND(Flight[Find_pos].Arrival$ = anywhere$ OR ts = 1)THEN
ts = 1
Flight[Find_pos].Skip = 0
END IF
Find_pos++
WEND
END SUB
FUNCTION IsFlight (frm$, dst$) AS INTEGER
DIM RAW d
DIM RAW dist
DIM RAW anywhere$
DIM RAW fany$
DIM RAW r
r = 0
IF Use_Method = Width THEN
dist = Find(frm$, anywhere$)
fany$ = anywhere$
WHILE dist
d = Match(anywhere$, dst$)
IF d THEN
Push(frm$, dst$, dist)
Push(anywhere$, dst$, d)
r = Route(dst$)
FUNCTION = r
END IF
dist = Find(frm$, anywhere$)
WEND
CALL ClearWidth(frm$, fany$)
END IF
IF Use_Method <> Width THEN
d = Match(frm$, dst$)
IF d THEN
Push(frm$, dst$, d)
r = Route(dst$)
IF Use_Method = Optimal AND r > 0 THEN
Pop(frm$, dst$, &dist)
CALL ClearFar
r = IsFlight(frm$, dst$)
END IF
FUNCTION = r
END IF
END IF
dist = Find(frm$, anywhere$)
IF dist THEN
Push(frm$, dst$, dist)
r = IsFlight(anywhere$, dst$)
ELSE
IF tos > 0 THEN
Pop(frm$, dst$, &dist)
CALL ClearFar
r = IsFlight(frm$, dst$)
END IF
END IF
FUNCTION = r
END FUNCTION
FUNCTION Route (dst$) AS INTEGER
DIM RAW dist
DIM RAW t
STATIC old_dist = 32000
IF Use_Method = Optimal AND tos = 0 THEN
FUNCTION = 0
END IF
dist = 0
t = 0
WHILE t < tos
IF Use_Method <> Optimal THEN PRINT Bt_Stack[t].Depart$; " to ";
dist += Bt_Stack[t].Distance
t++
WEND
IF Use_Method <> Optimal THEN
PRINT dst$
PRINT "Distance is "; dist
END IF
IF Use_Method = Optimal THEN
IF dist < old_dist AND dist > 0 THEN
t = 0
old_dist = dist
stos = 0
WHILE t < tos
CALL Spush(Bt_Stack[t].Depart$, Bt_Stack[t].Arrival$, Bt_Stack[t].Distance)
t++
WEND
END IF
END IF
FUNCTION = dist
END FUNCTION
SUB ClearMarkers
DIM RAW t
FOR t = 0 TO F_pos
Flight[t].Skip = 0
NEXT
END SUB
SUB Retract (frm$, dst$)
DIM RAW t
FOR t = 0 TO F_pos
IF Flight[t].Depart = frm$ AND Flight[t].Arrival$ = dst$ THEN
Flight[t].Depart$ = ""
EXIT SUB
END IF
NEXT
END SUB
Result:
From Here
to Hell and Back
Search by Depth
Search by Width
Search by Path Removal
Search by Node Removal
Optimal Search
Hell and Back
Distance is 0