DECLARE FUNCTION Testuj! ()
DECLARE FUNCTION TestXY! (x!, y!, co!)
'Cislo : 3
'Inicializace :
CLS

TYPE XY
 x AS INTEGER
 y AS INTEGER
END TYPE

SCREEN 12
COLOR 15
LOCATE 5
PRINT "Zadejte nazev souboru :"

'Pocet objektu bude Ob :
DIM SHARED Ob

'Pro urychleni prace :
CHDIR "e:\soutez"
SHELL "E:"

'Vstup :
INPUT "Soubor (pouze *.dat) : "; n$
IF LCASE$(RIGHT$(n$, 4)) <> ".dat" THEN n$ = n$ + ".dat"
RESET
OPEN n$ FOR INPUT AS #1
Ob = 0

'Nacteni poctu dat (=radku) :
DO UNTIL EOF(1)
 Ob = Ob + 1
 LINE INPUT #1, a$
LOOP
PRINT
PRINT "Nalezeno"; Ob; "objektu ."

'Nacteni dat :
SEEK #1, 1

DIM SHARED Nam$(1 TO Ob)
DIM SHARED Sou(1 TO 4, 1 TO Ob) AS XY
DIM SHARED PX, PY AS INTEGER'Velikost plochy
DIM SHARED Plocha AS INTEGER

AddX3 = 0'Soucet sirek objektu
MaxY3 = 0'Maximalni vyska objektu
Plocha = 0'Existuje plocha,kde ?

'Dekodace dat do poli a soucasne zjisteni velikosti plochy :
FOR i = 1 TO Ob
  LINE INPUT #1, a$
  a$ = a$ + ";"
  Poz = INSTR(a$, ";")'Poz je pozice na radku od ktere momentalne zpracovava
  Nam$(i) = LEFT$(a$, Poz - 1)
  SouX1 = 0
  SouY1 = 0
  FOR j = 1 TO 4
    Poz = Poz + 1
    PozNext = INSTR(Poz, a$, ";")
    Soutxt$ = MID$(a$, Poz, PozNext - Poz)
    Carka = INSTR(Soutxt$, ",")
    x = VAL(LEFT$(Soutxt$, Carka - 1)) - SouX1
    y = VAL(MID$(Soutxt$, Carka + 1)) - SouY1
    Poz = PozNext
  IF j = 1 THEN
    SouX1 = x
    SouY1 = y
    x = 0
    y = 0
  ELSEIF j = 3 THEN
    AddX3 = AddX3 + x
    IF y > MaxY3 THEN MaxY3 = y
    IF LTRIM$(RTRIM$(UCASE$(Nam$(i)))) = "PLOCHA" THEN
      Plocha = i
      PX = x
      PY = y
    END IF
  END IF
  Sou(j, i).x = x
  Sou(j, i).y = y
  NEXT
NEXT
CLOSE #1

'Test chybnych objektu :
Chyb = 0
FOR i = 1 TO Ob
  IF Sou(1, i).y = Sou(2, i).y AND Sou(2, i).x = Sou(3, i).x AND Sou(3, i).y = Sou(4, i).y AND Sou(4, i).x = Sou(1, i).x THEN
    ELSE
      Chyb = Chyb + 1
      PRINT "Objekt "; Nam$(i); " je chybny !"
  END IF
NEXT
IF Chyb THEN END

'Zobrazeni objektu :
CLS
PRINT "Objekty :"
MX = 640          'Maximalni souradnice na obrazovce
MY = 480
MerX = MX / AddX3 'Vypocet meritka
MerY = MY / MaxY3
StartX = 0        'Aktualni x-ova pozice na obrazovce
FOR i = 1 TO Ob
  NewStartX = StartX + MerX * Sou(3, i).x
  x1 = StartX
  y1 = 20
  x2 = NewStartX - 1
  y2 = 20 + MerY * Sou(3, i).y
  LINE (x1, y1)-(x2, y2), 7, BF
  LINE -(x1, y1), 15, B
  StartX = NewStartX
NEXT

'Ceka na stisk :
LOCATE 28
PRINT "Zmacknete ENTER nebo mezernik ..."
DO
SELECT CASE INKEY$
CASE CHR$(13), CHR$(32)
  EXIT DO
END SELECT
LOOP

'Zmena nazvu souboru nahradou .dat za .obs :
NTecka = INSTR(n$, ".")
IF NTecka = 0 THEN NTecka = LEN(n$) + 1
Obs$ = n$
MID$(Obs$, NTecka, 30) = ".obs"
CLS
PRINT "Ukladam obsahy do souboru *.obs :"
PRINT

'Vypocet a ulozeni obsahu :
OPEN Obs$ FOR OUTPUT AS #1
FOR i = 1 TO Ob
  PRNT$ = Nam$(i) + ": " + STR$((Sou(3, i).x * Sou(3, i).y))
  PRINT PRNT$
  PRINT #1, PRNT$
NEXT
CLOSE #1
PRINT
PRINT "Data ulozena ."

'---Pokus o rozmisteni objektu na plochu
DIM SHARED P(PX, PY) AS INTEGER

'Existuje plocha ?
IF Plocha = 0 THEN
  PRINT "Plocha NENALEZENA !!!"
  END
END IF

'Typ pokusu :
PRINT
PRINT
PRINT
PRINT "Povolite rotaci o 90 stupnu (=varianta B) (y/n/ESC) : _" + CHR$(&H1D);
                                                      'Umely kurzor na konci
DIM SHARED Povol
DIM SHARED Pokol'Pouze pomocna promena pro informaci,po kolikate je volana rekurze
DO
  i$ = LCASE$(INKEY$)
  SELECT CASE i$
  CASE "y", "n"
    PRINT i$
    EXIT DO
  CASE CHR$(27)
    PRINT "ESC"
    PRINT
    PRINT "Uz nic ."
    END
  END SELECT
LOOP
Povol = (i$ = "y")

'Test pomoci funkce Testuj pres rekurzi :
PRINT
PRINT "Hledam reseni ..."
IF Testuj THEN
  CLS
  PRINT "Zaplnena plocha :"
  FOR i = 1 TO PY
  FOR j = 1 TO PX
  PRINT MID$(STR$(P(j, i)), 2, 3);
  NEXT
  PRINT
  NEXT
ELSE
  PRINT "Nebylo nalezeno zadne reseni ."
END IF
COLOR 15
END

FUNCTION Testuj
'Tato funkce se pokousi davat kazdy objekt na kazde misto. ,,na kazde misto''
'zajistuje funkce TestXY.
'Navratova hodnota techto funkci je nenulova,pokud je jiz vytvoreno reseni.
'Tato nenulovost ukonci vsechny predchazejici funkce.

  Pokol = Pokol + 1'Puvodne pro kontrolu
REM  PRINT Pokol
  FOR O = 1 TO Ob
    IF Plocha <> O THEN 'Plochu do plochy davat nebude
      VelX = Sou(3, O).x
      VelY = Sou(3, O).y
      T = TestXY(VelX, VelY, O)
      Testuj = T
      IF T THEN EXIT FUNCTION
      IF Povol THEN
        T = TestXY(VelY, VelX, O)
        Testuj = T
        IF T THEN EXIT FUNCTION
      END IF
    END IF
  NEXT
  Pokol = Pokol - 1
END FUNCTION

FUNCTION TestXY (x, y, co)
  IF PX < x OR PY < y THEN EXIT FUNCTION
  FOR x1 = 1 TO PX - x + 1
  FOR y1 = 1 TO PY - y + 1
  Ok = 1
  FOR x2 = x1 TO x1 + x - 1
  FOR y2 = y1 TO y1 + y - 1
 
  IF P(x2, y2) THEN
    x2 = x1 + x
    y2 = y1 + y
    Ok = 0
  ELSE
    P(x2, y2) = co
  END IF
  NEXT
  NEXT
  IF Ok THEN
    FOR x2 = 1 TO PX
    FOR y2 = 1 TO PY
    IF P(x2, y2) = 0 THEN
      Ok = 0
      x2 = PX
      y2 = PY
    END IF
    NEXT
    NEXT
    IF Ok THEN
      TestXY = -1
      EXIT FUNCTION
    END IF
    FOR x2 = x1 TO x1 + x - 1
    FOR y2 = y1 TO y1 + y - 1
    P(x2, y2) = 0
    NEXT
    NEXT
  END IF
  NEXT
  NEXT

END FUNCTION