• Revista PROGRAMAR: Já está disponível a edição #53 da revista programar. Faz já o download aqui!

Tyagus

Party Planner

3 mensagens neste tópico

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  :thumbsup:

'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, 

0

Partilhar esta mensagem


Link para a mensagem
Partilhar noutros sites

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?

0

Partilhar esta mensagem


Link para a mensagem
Partilhar noutros sites

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?

0

Partilhar esta mensagem


Link para a mensagem
Partilhar noutros sites

Crie uma conta ou ligue-se para comentar

Só membros podem comentar

Criar nova conta

Registe para ter uma conta na nossa comunidade. É fácil!


Registar nova conta

Entra

Já tem conta? Inicie sessão aqui.


Entrar Agora