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

Tyagus

Party Planner

1 mensagem 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 (não é VB, isto ainda é do tempo do spectrum)  :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 © 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

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