Tyagus Posted November 6, 2006 at 04:27 PM Report #62435 Posted November 6, 2006 at 04:27 PM Boas, não sei se já alguém ouviu falar nisto, mas é um algoritmo muito famoso. Eu precisava de passar o algoritmo para Java, mas não sei, será que alguém me pode ajudar? Eu tenho o código em Basic 👍 'PARTY.BAS 'June 1997 by Marc Kummel aka Treebeard. 'Contact mkummel@rain.org, http://www.rain.org/~mkummel/ 'This is ancient code from the Vault circa 1987-8, inspired by A.K. Dewdney's 'Computer Recreations column in Scientific American, September 1987 (and 'reprinted in _The Magic Machine_ p.151). Dewdney credits the original idea 'to Richard Goldstein aka Rick Gold. I originally wrote this in QuickBasic '3.0 for a Hercules monochrome display. I've updated the colors, but tried 'to keep most of the code as was, though I couldn't resist a few changes. 'I'd do it differently today. This is real spaghetti code since it's all 'GOSUBs not procedures, and variables are all shared and not explicitly 'typed. There are too many variables, and there seems to be lots of 'duplicated code since it's easier to do it again than to figure out the 'interactions in what's already there. *Sigh* But it's still a pretty cool 'program, and I like the snappy way the menus work! It runs fine in QBasic. '****************************************************** '* PARTY PLANNER by TREEBEARD (c) December 1987 * '* * '* Idea from Computer Recreations, SciAm, Sep 1987 * '****************************************************** 'Declare procedures DECLARE SUB DrawBar (row%) DECLARE SUB GetKeyPress () DECLARE SUB OptionBar (startopt%, endopt%) DECLARE SUB Report (msg$) DECLARE SUB ShowMenu (startmenu%, endmenu%) DECLARE SUB SoundBip () DECLARE SUB SoundBop () DECLARE SUB TitleMsg (msg$) 'Declare variables CONST true = -1, false = 0 CONST empty = 0, dontcare = -1, bignum = 1E+34 CONST spacekey = 32, leftkey = 75, rightkey = 77, upkey = 72, downkey = 80 CONST homekey = 71, pgupkey = 73, pgdnkey = 81, endkey = 79, cr = 13 CONST backspacekey = 8, esckey = 27, inskey = 82, delkey = 83 CONST altplus = 131, altminus = 130 CONST black = 0, blue = 1, green = 2, cyan = 3, red = 4, magenta = 5 CONST brown = 6, white = 7, gray = 8, lightblue = 9, lightgreen = 10 CONST lightcyan = 11, lightred = 12, lightmagenta = 13, yellow = 14 CONST hiwhite = 15 CONST wide = 35, high = 19 CONST maxguests = 10 CONST maxobjects = 5 CONST maxgen = 800 DEFINT A-Z COMMON SHARED in1, in2, in$, choice DIM SHARED menu$(20), opt$(20), optab(20), saveline(159) REM $DYNAMIC DIM history(maxgen, maxguests, 2) REM $STATIC DIM x(maxguests), y(maxguests) DIM newx(maxguests), newy(maxguests) DIM savex(maxguests), savey(maxguests) DIM beginx(maxguests), beginy(maxguests) DIM obx(maxobjects), oby(maxobjects) DIM dobx(maxobjects), doby(maxobjects) DIM cobx(maxobjects), coby(maxobjects) DIM ideal!(maxguests, maxguests + maxobjects) DIM happy!(maxguests) DIM stathappy!(maxguests, maxguests + maxobjects) DIM name$(maxguests, 1), char$(maxguests) DIM object$(maxobjects), obchar$(maxobjects) DIM tb(4 + maxguests + maxobjects, 1), obtb(5) DIM randomname$(maxguests) RANDOMIZE TIMER esc$ = CHR$(27) q$ = CHR$(34) null$ = "" wheel$ = "|/-\" numguests = false delay! = 0 '************************************************************************* 'Data statements 'Read data for option bar READ nopt FOR i = 0 TO nopt: READ opt$(i): NEXT i 'Option bar data DATA 14 DATA Party!, Step, Begin, Edit, Random, Trace, Analyze, Graph, Optimize, Menu DATA Start, Guests, Objects, Position, Menu 'Read data for menus READ numenu FOR i = 0 TO numenu READ menu$(i) NEXT i 'Menu data DATA 6 DATA Current guest list DATA Default guest list DATA New guest list DATA Random guest list DATA Load guest file DATA Save guest file DATA Exit 'Data for guest review table (<tab,length> for each field) FOR i = 1 TO 4: READ tb(i, 0), tb(i, 1): NEXT i FOR i = 1 TO maxguests + maxobjects: tb(i + 4, 0) = 34 + i * 3: tb(i + 4, 1) = 3: NEXT i DATA 6,9,16,12,29,3,32,3 'Tab data for object table FOR i = 1 TO 5: READ obtb(i): NEXT i DATA 6,20,25,32,36 'Names for Random guests FOR i = 1 TO maxguests READ randomname$(i) NEXT i DATA Archie, Betty, Carter, Debby, Ewan DATA Frank, Ginger, Harry, Ines, Justin GuestData: 'Number of guests, objects DATA 8, 1 'Default guest name, occupation, ideal distances ' start pos. ideal distances ' name type (x,y) A B D M P S V W T ' ___________________________________________________________________ DATA Arthur, artist, 14, 16, 0, 15, 7, 2, 6, 9, 4, 12, 1 DATA Bernie, businessman, 11, 13, 8, 0, 6, 4, 6, 3, 2, 10, 1 DATA Dennis, dentist, 15, 14, 11, 4, 0, 5, 12, 2, 9, 6, 1 DATA Millie, model, 15, 15, 6, 9, 3, 0, 10, 7, 13, 5, 5 DATA Penelope, princess, 8, 6, 3, 10, 5, 14, 0, 11, 7, 15, 5 DATA Susan, stockbroker, 12, 12, 12, 2, 4, 8, 5, 0, 12, 4, 1 DATA Viola, violinist, 6, 12, 7, 8, 14, 10, 4, 13, 0, 3, 5 DATA Wally, weightlifter, 5, 7, 6, 7, 13, 6, 3, 8, 9, 0, 5 'Object data ' name start pos size ' __________________________ DATA Table, 16, 8, 7, 3 '************************************************************************* 'Function definitions 'Test for left and right room limits (ok=true) DEF FNTestX (col) = (col > 0 AND col <= wide) 'Test for up and down room limits (ok=true) DEF FNTestY (row) = (row > 0 AND row <= high) 'Test for object (true if NOT in object) DEF FNTestObject (col, row) FNTestObject = true FOR k = 1 TO numobjects IF (col >= obx(k) AND col < obx(k) + dobx(k) AND row >= oby(k) AND row <= oby(k) + doby(k) - 1) THEN FNTestObject = false EXIT FOR END IF NEXT k END DEF 'Test for valid digit DEF FNTestDigit = NOT ((in$ < "0" OR in$ > "9") AND in$ <> "-") 'Test for alpanumeric DEF FNTestAlpha = NOT (in$ < " " OR in$ > "~") '************************************************************************* '************************************************************************* Main: GOSUB ReadGuestData DO GOSUB GetPartyList IF NOT timetoquit THEN DO GOSUB Initialize GOSUB RunOptions DO UNTIL EndParty GOSUB MoveGuests GOSUB DisplayMove GOSUB ShowHappy GOSUB UpdateHistory GOSUB CheckOptions LOOP COLOR black, white CLS 2 IF editparty THEN GOSUB EditOptions LOOP WHILE editparty AND PartyDataOK END IF LOOP UNTIL timetoquit VIEW PRINT COLOR white, black CLS END '**************************************************************************** '**************************************************************************** GetPartyList: DO VIEW PRINT COLOR black, white CLS CALL DrawBar(1) PRINT " PARTY PLANNER" CALL TitleMsg("by TREEBEARD, Dec 1987/1997") VIEW PRINT 2 TO 24 CLS 2 COLOR black, white GOSUB IntroScreen GOSUB GuestList IF timetoquit THEN RETURN IF newdata THEN GOSUB ObjectList GOSUB DistanceTable GOSUB StartPosition END IF GOSUB EditOptions LOOP UNTIL PartyDataOK VIEW PRINT RETURN IntroScreen: IF skipintro THEN RETURN PRINT " So you're planning a party? Treebeard's PARTY PLANNER will help!" PRINT PRINT " This program is a party simulator. A group of guests with well-defined likes" PRINT " and dislikes is invited and allowed to interact. The party is held in a room" PRINT " which measures 35x20 units. There is a refreshment table of munchies, as well" PRINT " as other objects of your choosing. Each guest starts at a certain place in" PRINT " the room and then mixes with the other party-goers." PRINT PRINT " The assumption of this simulation is that there is an IDEAL SOCIAL DISTANCE" PRINT " that each guest would like to be from each other guest and from objects like" PRINT " the food table. Of course the ideals of the other guests may be quite" PRINT " different! As strict Utilitarians-but contrary to Jeremy Bentham-our guests" PRINT " choose to minimize unhappiness: consider all possible moves to adjacent" PRINT " positions and select the move that is least unpleasant. The complex dynamics" PRINT " of many party-goers all following the same principle are fascinating!" PRINT PRINT " To hold a party, you must provide: a list of guests (and optional occupations" PRINT " or stereotypes); a list of objects such as the refreshment table; a list of" PRINT " the ideal distances that each guest wants to be from each other guest and" PRINT " object; and the starting position in the room for each guest and object." PRINT PRINT " Default data is provided. Planning an interesting party is a lot of work!"; CALL DrawBar(25) PRINT " Press any key to continue."; CALL GetKeyPress skipintro = true RETURN GuestList: CALL DrawBar(25) COLOR black, white CLS 2 VIEW PRINT COLOR hiwhite, blue LOCATE 1, 20: PRINT SPACE$(60); DO CALL TitleMsg("Main menu") CLS 2 PRINT PRINT " First, you need a GUEST LIST. You can invite as many as"; maxguests; "guests to your" PRINT " party. You can use a predefined default list, the current list if different," PRINT " a list created during a previous session and saved on disk, or you can create" PRINT " a new list." PRINT : PRINT slm = CSRLIN LOCATE slm CALL ShowMenu(0, numenu) ok = true newdata = false SELECT CASE choice CASE 0 'current IF numguests = false THEN CALL Report("No current guest list!") ok = false END IF CASE 1 'default GOSUB ReadGuestData CASE 2 'new newdata = true GOSUB ClearArrays GOSUB NewGuestList IF numguests = false THEN CALL Report("No guests!") CLS 2: ok = false END IF CASE 3 'random GOSUB RandomParty CASE 4 'load GOSUB ReadFile CASE 5 'save IF numguests = false THEN CALL Report("Nothing to save!") ELSE GOSUB WriteFile END IF CLS 2 ok = false CASE 6 'quit timetoquit = true END SELECT LOOP UNTIL ok RETURN NewGuestList: CALL TitleMsg("New guest list") CLS 2 PRINT PRINT " Enter names and optional stereotypes for as many as 10 party guests. The" PRINT " first letter of each name is used for the party display, so keep these" PRINT " unique to avoid confusion. Data can be edited on the REVIEW screen. Press" PRINT " <Enter> on name field to end list." PRINT COLOR black, brown LOCATE , 2: PRINT TAB(30); LOCATE , 6: PRINT "Name Stereotype" LOCATE , 2: PRINT TAB(30); PRINT dy = 1 srow = CSRLIN - 1 nextmove = true DO COLOR black, brown LOCATE , 2: PRINT " "; DO COLOR black, cyan in$ = "": dx = 1 GOSUB GetString IF nstr$ = "" THEN EXIT DO dup = false char$ = CHR$(ASC(nstr$)) FOR i = 1 TO dy - 1 IF char$ = char$(i) THEN CALL Report("First letter not unique! Please enter another name.") dup = true EXIT FOR END IF NEXT i LOOP WHILE dup IF nstr$ = "" THEN CALL SoundBip: numguests = dy - 1: EXIT DO ELSE COLOR black, white GOSUB ShowField END IF in$ = "": dx = 2 GOSUB GetString COLOR black, white GOSUB ShowField dy = dy + 1 PRINT LOOP RETURN DistanceTable: CALL TitleMsg("Ideal distance table") CLS 2 PRINT PRINT " Now you must construct an IDEAL DISTANCE TABLE. This is work! For each guest," PRINT " specify the ideal distance he/she wants to be from each other guest and" PRINT " object (to 99 max). Enter -1 to indicate `doesn't care'. (Each guest is auto-" PRINT " matically set a distance 0 to himself.) Data can be edited on review screen." PRINT COLOR black, brown LOCATE , 2: PRINT TAB(80); LOCATE , 5: PRINT "Name Stereotype Ideal social distance: " LOCATE , 2: PRINT TAB(80); LOCATE , 37 FOR i = 1 TO numguests: PRINT " "; char$(i); " "; : NEXT i FOR i = 1 TO numobjects: PRINT " "; CHR$(ASC(object$(i))); " "; : NEXT i: PRINT srow = CSRLIN - 1 nextmove = true FOR i = 1 TO numguests LOCATE , 2 COLOR black, brown PRINT " "; char$(i); " "; COLOR black, white PRINT " "; name$(i, 0); TAB(16); name$(i, 1) NEXT i LOCATE srow + 1 FOR dy = 1 TO numguests FOR dx = 5 TO 5 + numguests + numobjects - 1 IF dx - 4 = dy THEN ideal!(dy, dx - 4) = 0! ELSE DO in$ = "": GOSUB GetNum IF num = -1 OR num > 0 THEN EXIT DO ELSE CALL Report("Distance must be in range -1 to 99.") END IF LOOP END IF COLOR black, white GOSUB ShowField NEXT dx NEXT dy RETURN StartPosition: CALL TitleMsg("Edit start position") CLS 2 GOSUB OptionPrompt CALL DrawBar(25) PRINT " <C>haracter or cursor keys to move, <ENTER> to pick up/drop, <ESC> to quit."; carry = false sx = 5 sy = 3 topedge = sy + 1 botedge = sy + high lftedge = sx + 1 ritedge = sx + wide GOSUB DrawRoom GOSUB ShowNames COLOR black, brown FOR obj = 1 TO numobjects dy = sy + oby(obj) dx = sx + obx(obj) GOSUB ShowObject NEXT obj COLOR black, cyan FOR i = 1 TO numguests LOCATE sy + y(i), sx + x(i) PRINT char$(i); NEXT i dx = 16: dy = 6 DO WHILE SCREEN(dy, dx) <> spacekey dx = dx + 1 LOOP COLOR black, blue LOCATE dy, dx: PRINT " "; cx = dx: cy = dy leavebehind = spacekey DO CALL GetKeyPress validmove = true IF in2 = upkey THEN 'up arrow dy = dy - 1: IF dy < topedge THEN dy = botedge ELSEIF in2 = downkey THEN 'down arrow dy = dy + 1: IF dy > botedge THEN dy = topedge ELSEIF in2 = leftkey THEN 'left arrow dx = dx - 1: IF dx < lftedge THEN dx = ritedge ELSEIF in2 = rightkey THEN 'right arrow dx = dx + 1: IF dx > ritedge THEN dx = lftedge ELSEIF in2 = homekey THEN 'upper left (Home) dx = lftedge: dy = topedge ELSEIF in2 = pgupkey THEN 'upper right (PgUp) dx = ritedge: dy = topedge ELSEIF in2 = pgdnkey THEN 'lower right (PgDn) dx = ritedge: dy = botedge ELSEIF in2 = endkey THEN 'lower left (End) dx = lftedge: dy = botedge ELSEIF in1 = cr THEN 'Enter validmove = false 'drop what we're carrying IF carry THEN IF char THEN leavebehind = carry: carry = false: CALL SoundBip x(char) = dx - sx y(char) = dy - sy COLOR black, white GOSUB Highlight COLOR black, blue LOCATE cy, cx: PRINT char$(char); ELSE COLOR black, brown GOSUB ShowObject IF fail THEN CALL Report("Something is in the way of the object!") ELSE leavebehind = carry: carry = false: CALL SoundBip obx(obj) = dx - sx: oby(obj) = dy - sy COLOR black, white GOSUB Highlight COLOR black, blue LOCATE dy, dx: PRINT obchar$(obj); END IF END IF 'or pick up what's there ELSE carry = SCREEN(cy, cx) IF carry = spacekey OR carry > 128 THEN CALL Report("There is nothing to pick up!") carry = false ELSE FOR char = 1 TO numguests IF ASC(char$(char)) = carry THEN EXIT FOR NEXT char IF char > numguests THEN char = false FOR obj = 1 TO numobjects IF ASC(object$(obj)) = carry THEN EXIT FOR NEXT obj GOSUB EraseObject END IF COLOR black, cyan GOSUB Highlight COLOR hiwhite, blue LOCATE cy, cx: PRINT CHR$(carry); CALL SoundBip leavebehind = spacekey END IF END IF ELSEIF in1 = esckey THEN EXIT DO ELSE in$ = UCASE$(CHR$(in1)) FOR i = 1 TO numguests IF in$ = char$(i) THEN EXIT FOR NEXT i IF i <= numguests THEN dx = x(i) + sx: dy = y(i) + sy ELSE FOR i = 1 TO numobjects IF in$ = obchar$(i) THEN EXIT FOR NEXT i IF i <= numguests THEN dx = obx(i) + sx: dy = oby(i) + sy ELSE validmove = false: CALL SoundBop END IF END IF END IF IF validmove THEN GOSUB MoveCursor LOOP RETURN MoveCursor: undercursor = SCREEN(dy, dx) IF carry THEN IF undercursor = spacekey THEN COLOR hiwhite, blue LOCATE dy, dx: PRINT CHR$(carry); COLOR black, cyan LOCATE cy, cx: PRINT " "; cx = dx: cy = dy ELSE dx = cx: dy = cy CALL SoundBop END IF ELSE IF undercursor < 128 THEN COLOR black, blue LOCATE dy, dx: PRINT CHR$(undercursor); COLOR black, cyan FOR obj = 1 TO numobjects IF ASC(object$(obj)) = leavebehind THEN COLOR black, brown EXIT FOR END IF NEXT obj LOCATE cy, cx: PRINT CHR$(leavebehind); cx = dx: cy = dy leavebehind = undercursor ELSE dx = cx: dy = cy CALL SoundBop END IF END IF RETURN Highlight: IF char THEN LOCATE sy + char + 1, 51: PRINT TAB(74); LOCATE , 51: PRINT name$(char, 0); TAB(61); name$(char, 1); ELSE LOCATE sy + numguests + 2 + obj, 48: PRINT SPACE$(14); LOCATE , 51: PRINT object$(obj); END IF RETURN ObjectList: CALL TitleMsg("New object list") CLS 2 PRINT PRINT " Objects influence the movements of guests, but they don't themselves move." PRINT " Enter the name and size for as many as 5 objects. As with guests, the first" PRINT " letter of each name is used for the party display, and must be different from" PRINT " the names of other guests and objects. Press <Enter> on name field to quit." PRINT " Object data can be edited from the review screen." PRINT COLOR black, brown LOCATE , 2: PRINT TAB(30); LOCATE , 4: PRINT "Object name Size" LOCATE , 2: PRINT TAB(30); LOCATE , 20: PRINT "wide high" dy = 1 srow = CSRLIN - 1 nextmove = true DO COLOR black, brown LOCATE , 2: PRINT " "; DO COLOR black, cyan in$ = "": dx = 1 GOSUB GetObjString IF nstr$ = "" THEN EXIT DO dup = false char$ = LEFT$(nstr$, 1) FOR i = 1 TO dy - 1 IF char$ = obchar$(i) THEN dup = true: EXIT FOR NEXT i FOR i = 1 TO numguests IF char$ = char$(i) THEN dup = true: EXIT FOR NEXT i IF dup THEN CALL Report("First letter not unique! Please enter another name.") LOOP WHILE dup IF nstr$ = "" THEN CALL SoundBip: numobjects = dy - 1 GOSUB CenterObjects: EXIT DO ELSE object$(dy) = nstr$: obchar$(dy) = char$ COLOR black, brown LOCATE , 3: PRINT char$ COLOR black, white GOSUB ShowObjField END IF DO dx = 2: in$ = "": GOSUB GetObjNum IF num > 0 AND num <= wide THEN fail = false: dobx(dy) = num: COLOR black, white GOSUB ShowObjField ELSE CALL Report("Bad value!"): fail = true END IF LOOP WHILE fail DO dx = 3: in$ = "": GOSUB GetObjNum IF num > 0 AND num <= high THEN fail = false: doby(dy) = num COLOR black, white GOSUB ShowObjField ELSE CALL Report("Bad value!"): fail = true END IF LOOP WHILE fail dy = dy + 1 PRINT LOOP COLOR black, white GOSUB ShowObjField RETURN ShowObject: IF obj <= numobjects THEN fail = false FOR row = dy TO dy + doby(obj) - 1 FOR col = dx TO dx + dobx(obj) - 1 IF (row <> dy OR col <> dx) AND SCREEN(row, col) <> spacekey THEN fail = true NEXT col NEXT row IF NOT fail THEN FOR row = dy TO dy + doby(obj) - 1 LOCATE row, dx: PRINT STRING$(dobx(obj), 176) NEXT row LOCATE dy, dx: PRINT obchar$(obj); END IF END IF RETURN EraseObject: COLOR black, cyan FOR row = dy TO dy + doby(obj) - 1 LOCATE row, dx: PRINT SPACE$(dobx(obj)) NEXT row COLOR black, brown LOCATE dy, dx: PRINT obchar$(obj); RETURN CenterObjects: FOR i = 1 TO numobjects cobx(i) = obx(i) + dobx(i) \ 2 coby(i) = oby(i) + doby(i) \ 2 NEXT i RETURN EditOptions: GOSUB ShowGuestData CALL TitleMsg("Edit party data") DO CALL SoundBip CALL OptionBar(10, 14) SELECT CASE choice CASE 10 'start party PartyDataOK = true EXIT DO CASE 11 'Edit guest list GOSUB ShowGuestData GOSUB ReviewData CASE 12 'Edit object list GOSUB ReviewObjects CASE 13 'Edit start position GOSUB StartPosition CASE 14 'Menu PartyDataOK = false EXIT DO END SELECT LOOP RETURN ReadGuestData: RESTORE GuestData READ numguests, numobjects FOR i = 1 TO numguests READ name$(i, 0), name$(i, 1) char$(i) = CHR$(ASC(name$(i, 0))) READ x(i), y(i) FOR j = 1 TO numguests + numobjects READ ideal!(i, j) NEXT j NEXT i FOR i = 1 TO numobjects READ object$(i) READ obx(i), oby(i), dobx(i), doby(i) obchar$(i) = CHR$(ASC(object$(i))) cobx(i) = obx(i) + dobx(i) \ 2 coby(i) = oby(i) + doby(i) \ 2 NEXT i RETURN ReadFile: CALL TitleMsg("Load data file") CLS 2 LOCATE 3, 1 PRINT " Enter name of party data file [*.PTY] to LOAD, or <?> for directory," PRINT " or <null> to abort." PRINT : INPUT " Load file= ", file$ IF file$ = esc$ OR file$ = "" THEN ok = false: RETURN IF RIGHT$(file$, 1) = "?" THEN GOSUB ShowDir: GOTO ReadFile IF INSTR(file$, ".") = false THEN file$ = file$ + ".PTY" ON ERROR GOTO ReadError OPEN file$ FOR INPUT AS #1 INPUT #1, numguests, numobjects FOR i = 1 TO numguests INPUT #1, name$(i, 0), name$(i, 1) char$(i) = CHR$(ASC(name$(i, 0))) INPUT #1, x(i), y(i) FOR j = 1 TO numguests + numobjects INPUT #1, ideal!(i, j) NEXT j NEXT i FOR i = 1 TO numobjects INPUT #1, object$(i), obx(i), oby(i), dobx(i), doby(i) cobx(i) = obx(i) + dobx(i) \ 2 coby(i) = oby(i) + doby(i) \ 2 obchar$(i) = CHR$(ASC(object$(i))) NEXT i CLOSE #1: ON ERROR GOTO 0 RETURN WriteFile: CALL TitleMsg("Save data file") CLS 2 LOCATE 3, 1 PRINT " Enter name of party data file [*.PTY] to SAVE, or <?> for directory," PRINT " or <null> to abort." PRINT : INPUT " Save file= ", file$ IF file$ = esc$ OR file$ = "" THEN RETURN IF RIGHT$(file$, 1) = "?" THEN GOSUB ShowDir: GOTO WriteFile IF INSTR(file$, ".") = false THEN file$ = file$ + ".PTY" ON ERROR GOTO WriteError OPEN file$ FOR OUTPUT AS #1 PRINT #1, numguests; numobjects FOR i = 1 TO numguests PRINT #1, q$; name$(i, 0); q$; q$; name$(i, 1); q$; x(i); y(i); FOR j = 1 TO numguests + numobjects PRINT #1, ideal!(i, j); NEXT j PRINT #1, NEXT i FOR i = 1 TO numobjects PRINT #1, q$; object$(i); q$; obx(i); oby(i); dobx(i); doby(i) NEXT i CLOSE #1: ON ERROR GOTO 0 RETURN ReadError: CALL Report("Cannot read data file!") CLOSE #1: CLS 2 RESUME ReadFile WriteError: CALL Report("Cannot write data file!") CLOSE #1: CLS 2 RESUME WriteFile DirError: CALL Report("Cannot read directory!") CLS 2 RESUME ExitDir ShowDir: ON ERROR GOTO DirError DO WHILE RIGHT$(file$, 1) = "?" file$ = LEFT$(file$, LEN(file$) - 1) LOOP IF file$ = "" THEN file$ = "*.PTY" PRINT : FILES file$ PRINT : PRINT " Press any key to continue.": CALL GetKeyPress ExitDir: ON ERROR GOTO 0 RETURN ClearArrays: FOR i = 1 TO maxguests: x(i) = 2 + i * 2: y(i) = 1: char$(i) = "": NEXT i FOR i = 1 TO maxobjects: obx(i) = 2 + (i - 1) * 15: oby(i) = 10: NEXT i RETURN Initialize: EndParty = false gen = 0 least! = bignum maxtotal! = 0 FOR i = 1 TO numguests newx(i) = x(i): newy(i) = y(i) beginx(i) = x(i): beginy(i) = y(i) NEXT i GOSUB CenterObjects GOSUB InitScreen RETURN InitScreen: VIEW PRINT COLOR black, white CLS CALL DrawBar(1): PRINT " PARTY PLANNER"; LOCATE , 60: PRINT "Move number"; gen sx = 5: sy = 3 GOSUB BottomLine GOSUB DrawRoom GOSUB DrawObjects COLOR black, cyan FOR i = 1 TO numguests LOCATE y(i) + sy, x(i) + sx: PRINT char$(i); NEXT i GOSUB ShowNames GOSUB CheckStatHappy IF least! = bignum THEN least! = stattotal! IF maxtotal! = 0 THEN maxtotal! = stattotal! GOSUB ShowStatHappy RETURN BottomLine: CALL DrawBar(25) PRINT " Press <+-> for speed or <Space> for options/pause."; RETURN OptionPrompt: CALL DrawBar(25) PRINT " Press <Esc> for options."; COLOR black, white RETURN DrawRoom: COLOR black, cyan LOCATE 3, 4 PRINT " "; CHR$(201); STRING$(wide, 205); CHR$(187); " " FOR i = 1 TO high LOCATE , 4 PRINT " "; CHR$(186); TAB(5 + wide + 1); CHR$(186); " " NEXT i LOCATE , 4 PRINT " "; CHR$(200); STRING$(wide, 205); CHR$(188); " " RETURN ShowNames: LOCATE sy, 48 COLOR black, white PRINT "Cast of Characters:": PRINT FOR i = 1 TO numguests LOCATE , 48 PRINT char$(i); PRINT " "; PRINT name$(i, 0); TAB(61); name$(i, 1) NEXT i PRINT FOR i = 1 TO numobjects LOCATE , 48 PRINT obchar$(i); PRINT " "; PRINT object$(i) NEXT i LOCATE 21, 48: PRINT "Total Unhappiness:"; LOCATE 22, 48: PRINT " Most Unhappiness:"; LOCATE 23, 48: PRINT "Least Unhappiness:"; RETURN DrawObjects: IF numobjects > false THEN COLOR black, brown FOR i = 1 TO numobjects FOR row = oby(i) TO oby(i) + doby(i) - 1 LOCATE row + sy, obx(i) + sx: PRINT STRING$(dobx(i), 176) NEXT row LOCATE coby(i) + sy, cobx(i) + sx PRINT obchar$(i); NEXT i END IF RETURN DisplayMove: COLOR black, cyan FOR i = 1 TO numguests LOCATE y(i) + sy, x(i) + sx: PRINT " "; LOCATE newy(i) + sy, newx(i) + sx: PRINT char$(i); NEXT i RETURN ShowHappy: COLOR black, white LOCATE sy + 2 FOR i = 1 TO numguests LOCATE , 74: PRINT USING "###.#"; happy!(i) NEXT i LOCATE 21, 70: PRINT total!; LOCATE 22, 70: PRINT maxtotal!; LOCATE 23, 70: PRINT least!; RETURN Wait5sec: i! = TIMER DO in$ = INKEY$ LOOP UNTIL TIMER = i! + 5 OR in$ <> "" RETURN 'figure a move. Put new positions in newx() and newy(). MoveGuests: FOR i = 1 TO numguests smallsum! = bignum FOR dx = -1 TO 1 xx = x(i) + dx IF FNTestX(xx) THEN FOR dy = -1 TO 1 yy = y(i) + dy IF FNTestY(yy) AND FNTestObject(xx, yy) THEN sum! = 0 FOR j = 1 TO numguests IF ideal!(i, j) > 0 THEN dist! = SQR((xx - x(j)) * (xx - x(j)) + (yy - y(j)) * (yy - y(j))) sum! = sum! + ABS(dist! - ideal!(i, j)) END IF NEXT j FOR j = 1 TO numobjects IF ideal!(i, j + numguests) > 0 THEN dist! = SQR((xx - cobx(j)) * (xx - cobx(j)) + (yy - coby(j)) * (yy - coby(j))) sum! = sum! + ABS(dist! - ideal!(i, j + numguests)) END IF NEXT j IF sum! < smallsum! THEN smallsum! = sum! newx(i) = xx newy(i) = yy END IF END IF NEXT dy END IF NEXT dx NEXT i HappyGuests: 'now recheck happiness AFTER everyone moves total! = 0 FOR i = 1 TO numguests sum! = 0 xx = newx(i): yy = newy(i) FOR j = 1 TO numguests IF ideal!(i, j) > 0 THEN dist! = SQR((xx - newx(j)) * (xx - newx(j)) + (yy - newy(j)) * (yy - newy(j))) sum! = sum! + ABS(dist! - ideal!(i, j)) END IF NEXT j FOR j = 1 TO numobjects IF ideal!(i, j + numguests) > 0 THEN dist! = SQR((xx - cobx(j)) * (xx - cobx(j)) + (yy - coby(j)) * (yy - coby(j))) sum! = sum! + ABS(dist! - ideal!(i, j + numguests)) END IF NEXT j happy!(i) = sum! total! = total! + sum! NEXT i IF total! < least! THEN least! = total! IF total! > maxtotal! THEN maxtotal! = total! RETURN 'build table of all current happiness values. 'stathappy!(i,0) contains total for i CheckStatHappy: stattotal! = 0 FOR i = 1 TO numguests sum! = 0 xx = x(i): yy = y(i) FOR j = 1 TO numguests IF ideal!(i, j) > 0 THEN dist! = SQR((xx - x(j)) * (xx - x(j)) + (yy - y(j)) * (yy - y(j))) sum! = sum! + ABS(dist! - ideal!(i, j)) stathappy!(i, j) = dist! ELSE stathappy!(i, j) = 0 END IF NEXT j FOR j = 1 TO numobjects IF ideal!(i, j + numguests) > 0 THEN dist! = SQR((xx - cobx(j)) * (xx - cobx(j)) + (yy - coby(j)) * (yy - coby(j))) sum! = sum! + ABS(dist! - ideal!(i, j + numguests)) stathappy!(i, j + numguests) = dist! ELSE stathappy!(i, j + numguests) = 0 END IF NEXT j stathappy!(i, 0) = sum! stattotal! = stattotal! + sum! NEXT i RETURN ShowStatHappy: COLOR black, white LOCATE sy + 2 FOR i = 1 TO numguests LOCATE , 74: PRINT USING "###.#"; stathappy!(i, 0) NEXT i LOCATE 21, 70: PRINT stattotal!; LOCATE 22, 70: IF maxtotal! > 0 THEN PRINT maxtotal!; LOCATE 23, 70: IF least! < bignum THEN PRINT least!; PRINT TAB(80); RETURN UpdateHistory: COLOR hiwhite, blue LOCATE 1, 71: PRINT gen; FOR i = 1 TO numguests x(i) = newx(i) y(i) = newy(i) NEXT i IF gen <= maxgen THEN history(gen, 0, 2) = CINT(total!) FOR i = 1 TO numguests history(gen, i, 0) = x(i) history(gen, i, 1) = y(i) history(gen, i, 2) = CINT(happy!(i)) NEXT i END IF gen = gen + 1 RETURN CheckOptions: in$ = INKEY$ IF delay! = 0! AND LEN(in$) = 0 THEN RETURN endtime! = TIMER + delay! DO SELECT CASE in$ CASE "-" endtime! = endtime! - .03 delay! = delay! - .03 IF delay! < 0 THEN delay! = 0 CASE "+" endtime! = endtime! + .03 delay! = delay! + .03 CASE " ", esc$ EXIT DO END SELECT in$ = INKEY$ LOOP WHILE TIMER < endtime! IF in$ <> " " AND in$ <> esc$ THEN RETURN GOSUB CheckStatHappy GOSUB ShowStatHappy RunOptions: DO CALL OptionBar(0, 9) SELECT CASE choice CASE 0 'Continue GOSUB BottomLine EXIT DO CASE 1 'Step GOSUB MoveGuests GOSUB DisplayMove GOSUB ShowHappy GOSUB UpdateHistory CASE 2 'Begin FOR i = 1 TO numguests x(i) = beginx(i): y(i) = beginy(i) NEXT i gen = 0 GOSUB InitScreen CASE 3 'Edit EndParty = true editparty = true timetoquit = false VIEW PRINT 2 TO 24 COLOR black, white: CLS 2 EXIT DO CASE 4 'Random GOSUB RandomGuests gen = 0 least! = bignum maxtotal! = 0 GOSUB InitScreen CASE 5 'Trace GOSUB Trace GOSUB InitScreen CASE 6 'Analyze GOSUB Analyze GOSUB InitScreen CASE 7 'Graph GOSUB Graph GOSUB InitScreen CASE 8 'Optimize GOSUB Optimize GOSUB InitScreen CASE 9 'Menu EndParty = true editparty = false timetoquit = false COLOR black, white: CLS 2 EXIT DO END SELECT LOOP RETURN Graph: IF gen = 0 THEN Report ("No data!"): RETURN CALL DrawBar(25) PRINT " Press <Cursor> keys, <Enter> for total or <C>haracter, or <Esc> to continue"; GOSUB SavePosition IF gen > maxgen THEN ngen = maxgen ELSE ngen = gen - 1 char = 0 'show totals sgen = 0 lastchar = -1 DO GOSUB DrawGraph DO tchar$ = INKEY$ LOOP UNTIL LEN(tchar$) tchar$ = UCASE$(tchar$) SELECT CASE tchar$ CASE esc$ EXIT DO CASE CHR$(0) + CHR$(rightkey) n = sgen + 10 IF n > ngen THEN SoundBop ELSE sgen = n CASE CHR$(0) + CHR$(leftkey) n = sgen - 10 IF sgen = 0 THEN SoundBop ELSE sgen = sgen - 10: IF sgen < 0 THEN sgen = 0 CASE " ", CHR$(0) + CHR$(downkey), CHR$(0) + CHR$(pgdnkey) n = sgen + 70 IF n > ngen THEN SoundBop ELSE sgen = n CASE CHR$(0) + CHR$(upkey), CHR$(0) + CHR$(pgupkey) IF sgen = 0 THEN SoundBop ELSE sgen = sgen - 70: IF sgen < 0 THEN sgen = 0 CASE CHR$(0) + CHR$(homekey) IF sgen = 0 THEN SoundBop ELSE sgen = 0 CASE CHR$(0) + CHR$(endkey) IF (ngen \ 70) * 70 = sgen THEN SoundBop ELSE sgen = (ngen \ 70) * 70 CASE CHR$(cr) char = 0 sgen = 0 CASE ELSE FOR i = 1 TO numguests IF tchar$ = char$(i) THEN EXIT FOR NEXT i IF i > numguests THEN CALL SoundBop ELSE char = i: sgen = 0 END SELECT LOOP FOR i = 1 TO numguests x(i) = savex(i) y(i) = savey(i) NEXT i RETURN DrawGraph: 'pick a vertical scale from max to min IF char <> lastchar THEN lastchar = char min = 32000 max = 0 FOR i = 0 TO ngen IF history(i, char, 2) < min THEN min = history(i, char, 2) IF history(i, char, 2) > max THEN max = history(i, char, 2) NEXT i vmin = (min \ 10) * 10 vmax = (2 + max \ 10) * 10 vscale = (vmax - vmin) \ 20 END IF COLOR black, white VIEW PRINT 2 TO 24 CLS 2 VIEW PRINT yaxis = 7 LOCATE 2, 2 IF char = 0 THEN t$ = "Total" ELSE t$ = name$(char, 0) + "'s" PRINT t$ + " Unhappiness (" + LTRIM$(STR$(min)) + " to " + LTRIM$(STR$(max)) + ")"; LOCATE 24, 2: PRINT "Move"; FOR i = 0 TO 20 LOCATE 23 - i, yaxis IF i MOD 5 THEN PRINT CHR$(179); ELSE PRINT CHR$(180); t$ = LTRIM$(STR$(vmin + i * vscale)) LOCATE , yaxis - LEN(t$) - 1: PRINT t$; END IF NEXT i LOCATE 23, yaxis PRINT CHR$(193); CHR$(194); FOR i = 1 TO 7 PRINT STRING$(9, 196); CHR$(194); NEXT i LOCATE 24 FOR i = 0 TO 7 t$ = LTRIM$(STR$(sgen + i * 10)) LOCATE , yaxis + i * 10 - LEN(t$) \ 2 + 1 PRINT t$; NEXT i FOR i = 0 TO 70 IF sgen + i > ngen THEN EXIT FOR n = 1 + ((history(sgen + i, char, 2) - vmin) \ vscale) IF n > 20 THEN n = 20 IF n < 1 THEN n = 1 LOCATE 23 - n, yaxis + i + 1 PRINT "*"; NEXT i RETURN Trace: IF gen = 0 THEN Report ("No data!"): RETURN trc = 0 IF gen > maxgen THEN ngen = maxgen ELSE ngen = gen - 2 DO CALL DrawBar(25) PRINT " <C>haracter to trace, <Enter> for next, <?> to clear, or <Esc> to continue:"; DO tchar$ = INKEY$ LOOP UNTIL LEN(tchar$) tchar$ = UCASE$(tchar$) IF tchar$ = esc$ THEN EXIT DO ELSEIF tchar$ = CHR$(13) THEN char = char + 1 IF char > numguests THEN char = 1 ELSEIF tchar$ = "?" THEN GOSUB InitScreen tchar$ = "" ELSE FOR char = 1 TO numguests IF tchar$ = char$(char) THEN EXIT FOR NEXT char IF char > numguests THEN CALL SoundBop: tchar$ = "" END IF IF tchar$ <> "" THEN COLOR black, brown LOCATE sy + history(0, char, 1), sx + history(0, char, 0) PRINT char$(char); COLOR brown, cyan FOR i = 1 TO ngen LOCATE sy + history(i, char, 1), sx + history(i, char, 0) PRINT CHR$(248 + trc); NEXT i COLOR black, brown LOCATE sy + y(char), sx + x(char) PRINT char$(char); trc = (trc + 1) MOD 3 END IF LOOP RETURN Analyze: IF gen = 0 THEN Report ("No data!"): RETURN char = 0 DO CALL DrawBar(25) PRINT " <C>haracter to analyze, <Enter> for next, or <Esc> to continue:"; DO tchar$ = INKEY$ LOOP UNTIL LEN(tchar$) tchar$ = UCASE$(tchar$) IF tchar$ = esc$ THEN EXIT DO ELSEIF tchar$ = CHR$(13) THEN char = char + 1 IF char > numguests THEN char = 1 ELSE FOR char = 1 TO numguests IF tchar$ = char$(char) THEN EXIT FOR NEXT char IF char > numguests THEN CALL SoundBop: tchar$ = "" END IF IF tchar$ <> "" THEN COLOR black, cyan LOCATE sy, 48 PRINT "Analyze "; name$(char, 0); " the "; name$(char, 1); ":"; TAB(80); LOCATE sy + 1, 48 PRINT TAB(51); "name"; TAB(59); "ideal"; TAB(67); "real"; TAB(75); "dst"; TAB(80); PRINT COLOR black, white FOR i = 1 TO numguests + numobjects IF i = char THEN LOCATE , 61 PRINT "-"; TAB(68); "-"; TAB(76); "-"; TAB(80); ELSE LOCATE , 60 PRINT ideal!(char, i); TAB(66); PRINT USING "##.##"; stathappy!(char, i); TAB(74); PRINT USING "##.##"; ABS(ideal!(char, i) - stathappy!(char, i)); TAB(80); END IF PRINT IF i = numguests THEN PRINT NEXT i LOCATE 21, 70: PRINT stathappy!(char, 0); TAB(80); LOCATE 22, 48: PRINT TAB(80); LOCATE 23, 48: PRINT TAB(80); END IF LOOP RETURN 'added june 97 'Pick random start and run a few. Keep repeating to find best position. Optimize: CALL DrawBar(25) PRINT " Seeking happiness...Press any key to quit."; optimum! = bignum least! = bignum maxiter = 50 wheelptr = 1 GOSUB SavePosition DO UNTIL LEN(INKEY$) COLOR hiwhite, blue LOCATE 25, 45: PRINT MID$(wheel$, wheelptr, 1); wheelptr = wheelptr + 1: IF wheelptr > 4 THEN wheelptr = 1 GOSUB RandomGuests FOR opiter = 1 TO maxiter GOSUB MoveGuests FOR i = 1 TO numguests x(i) = newx(i) y(i) = newy(i) NEXT i IF total! < optimum! THEN SOUND 660, .5 COLOR black, cyan FOR i = 1 TO numguests LOCATE savey(i) + sy, savex(i) + sx: PRINT " "; NEXT i FOR i = 1 TO numguests LOCATE y(i) + sy, x(i) + sx: PRINT char$(i); NEXT i GOSUB SavePosition GOSUB ShowHappy optimum! = total! END IF NEXT opiter LOOP FOR i = 1 TO numguests x(i) = savex(i) y(i) = savey(i) NEXT i RETURN SavePosition: FOR i = 1 TO numguests savex(i) = x(i) savey(i) = y(i) NEXT i RETURN 'make a totally random party RandomParty: CALL DrawBar(25) PRINT " Working..."; numobjects = RND * (maxobjects) '0-max IF numobjects THEN FOR i = 1 TO numobjects object$(i) = CHR$(ASC("P") + i - 1) + "-object" obchar$(i) = LEFT$(object$(i), 1) dobx(i) = 1 + INT(RND * 6) doby(i) = 1 + INT(RND * 6) IF dobx(i) MOD 2 = 0 THEN dobx(i) = dobx(i) + 1 IF doby(i) MOD 2 = 0 THEN doby(i) = doby(i) + 1 NEXT i GOSUB RandomObjects END IF numguests = 2 + INT(RND * (maxguests - 1)) 'at least 2 FOR i = 1 TO numguests name$(i, 0) = randomname$(i) name$(i, 1) = LEFT$(name$(i, 0), 1) + "-guest" char$(i) = LEFT$(name$(i, 0), 1) NEXT i GOSUB RandomGuests GOSUB RandomIdeals RETURN 'Put objects in legal random places without overlap. 'Ignore guests. (Do this first) RandomObjects: FOR i = 1 TO numobjects cnt = 0 flag = false DO 'bail if it hangs cnt = cnt + 1 IF cnt > 1000 THEN numobjects = i - 1: RETURN x = 1 + INT(RND * (wide - dobx(i))) y = 1 + INT(RND * (high - doby(i))) FOR j = 1 TO i - 1 IF x >= obx(j) AND x < obx(j) + dobx(j) AND y >= oby(j) AND y <= oby(j) + doby(j) - 1 THEN flag = true EXIT FOR END IF NEXT j LOOP WHILE flag obx(i) = x: oby(i) = y NEXT i RETURN 'Put guests in random legal places. Keep objects where they are! RandomGuests: FOR i = 1 TO numguests flag = true DO xx = 1 + INT(RND * (wide - 1)) yy = 1 + INT(RND * (high - 1)) IF FNTestObject(xx, yy) THEN flag = false FOR j = 1 TO i - 1 IF xx = x(j) AND yy = y(j) THEN flag = true: EXIT FOR NEXT j END IF LOOP WHILE flag x(i) = xx: y(i) = yy NEXT i RETURN 'Make up random ideal!() table for guests RandomIdeals: FOR i = 1 TO numguests FOR j = 1 TO numguests + numobjects IF i = j THEN ideal!(i, j) = 0 ELSE ideal!(i, j) = INT(RND * (wide \ 2)) IF ideal!(i, j) = 0! THEN ideal!(i, j) = -1 END IF NEXT j NEXT i RETURN ShowGuestData: CALL TitleMsg("Edit guest data") CLS 2 PRINT PRINT " This is the current GUEST LIST. To edit data, use cursor key to position the" PRINT " highlighted cursor to the desired data field, then enter new data and press" PRINT " <Enter>. Move cursor off field to abort data entry. With the cursor in the" PRINT " name field, press <ALT +> to create a new guest or <ALT -> to delete one." PRINT COLOR black, brown LOCATE , 2: PRINT TAB(80); LOCATE , 6: PRINT "Name Stereotype Place Ideal social distance:" LOCATE , 2: PRINT TAB(80); LOCATE , 27: PRINT "(col,row) "; FOR i = 1 TO numguests: PRINT " "; char$(i); " "; : NEXT i FOR i = 1 TO numobjects: PRINT " "; CHR$(ASC(object$(i))); " "; : NEXT i: PRINT srow = CSRLIN - 1: newdata = false FOR i = 1 TO numguests COLOR black, brown LOCATE , 2 PRINT " "; char$(i); " "; COLOR black, white PRINT " "; name$(i, 0); TAB(16); name$(i, 1); TAB(28); PRINT USING "###"; x(i); y(i); : PRINT TAB(36); FOR j = 1 TO numguests + numobjects PRINT " "; : PRINT USING "##"; ideal!(i, j); NEXT j PRINT NEXT i RETURN ReviewData: GOSUB OptionPrompt dx = 1: dy = 1 cx = 1: cy = 1 xmax = 4 + numguests + numobjects COLOR black, cyan GOSUB ShowField nextmove = true DO validmove = true IF nextmove THEN CALL GetKeyPress ELSE nextmove = true END IF IF in2 = leftkey THEN dx = dx - 1: IF dx < 1 THEN dx = xmax ELSEIF in2 = rightkey THEN dx = dx + 1: IF dx > xmax THEN dx = 1 ELSEIF in2 = upkey THEN dy = dy - 1: IF dy < 1 THEN dy = numguests ELSEIF in2 = downkey THEN dy = dy + 1: IF dy > numguests THEN dy = 1 ELSEIF in2 = altplus AND dx = 1 THEN GOSUB InsertGuest ELSEIF in2 = altminus AND dx = 1 THEN GOSUB DeleteGuest ELSEIF dx > 2 AND FNTestDigit = true THEN GOSUB GetNum ELSEIF dx < 3 AND FNTestAlpha THEN GOSUB GetString ELSEIF in1 = esckey THEN EXIT DO ELSE CALL SoundBip: validmove = false END IF IF validmove THEN SWAP dx, cx: SWAP dy, cy COLOR black, white: GOSUB ShowField SWAP dx, cx: SWAP dy,
Knitter Posted November 6, 2006 at 04:36 PM Report #62438 Posted November 6, 2006 at 04:36 PM Posso ajudar-te a passar o algoritmo mas tens de ter em atenção que queres passar um algoritmo numa linguagem funcional para uma linguagem orientada a objectos... Agora estou a ter aula, entretanto posso dar uma olhadela ao algoritmo. Nunca tinha ouvido falar, para que serve?
Knitter Posted November 6, 2006 at 04:45 PM Report #62440 Posted November 6, 2006 at 04:45 PM Este código é horrivel!!! Variáveis globais?! Repetições de código?! Não existe por aí uma descrição do algoritmo além desta implementação?
Recommended Posts
Create an account or sign in to comment
You need to be a member in order to leave a comment
Create an account
Sign up for a new account in our community. It's easy!
Register a new accountSign in
Already have an account? Sign in here.
Sign In Now