'Program od start.c. 16'

                                                        'inicializace'
SCREEN 12
DIM u$(200)
DIM naz$(200)
DIM obs(200)
DIM sour(200, 8)
ON ERROR GOTO konec
CLS                                             'otevreni a cteni souboru'
INPUT "jmeno souboru (bez konc.)"; jm$          'predpodlada se ze PLOCHA je'
jmpd$ = jm$ + ".dat"                            'v souboru jako posledni'
OPEN jmpd$ FOR INPUT AS #1
a = 0
10 a = a + 1
INPUT #1, u$(a)
GOTO 10
konec:
ON ERROR GOTO 999
delka = a
CLOSE #1
CLS                                                     'dale nasleduje'
FOR B = 1 TO delka - 1 STEP 5                           'dolorvani souradnic'
kn = 0                                                  'ze souboru'
FOR a = 1 TO LEN(u$(B))
cn = (B + 4) / 5
p$ = MID$(u$(B), a, 1)
IF p$ = ";" THEN kn = 1
IF kn = 0 THEN naz$(cn) = naz$(cn) + p$
NEXT a
NEXT B

FOR B = 2 TO delka - 1 STEP 5
kn = 0
FOR a = 1 TO LEN(u$(B))
cs = (B + 4) / 5
p$ = MID$(u$(B), a, 1)
IF kn = 1 THEN kn = 2
IF p$ = ";" THEN kn = 1
IF kn = 2 THEN IF sour(cs, 3) <> 0 THEN sour(cs, 3) = sour(cs, 3) * 10 + VAL(p$)
IF kn = 2 THEN IF sour(cs, 3) = 0 THEN sour(cs, 3) = VAL(p$)
NEXT a
NEXT B

FOR B = 3 TO delka - 1 STEP 5
kn = 0
FOR a = 1 TO LEN(u$(B))
cs = (B + 4) / 5
p$ = MID$(u$(B), a, 1)
IF kn = 1 THEN kn = 2
IF p$ = ";" THEN kn = 1
IF kn = 2 THEN IF sour(cs, 5) <> 0 THEN sour(cs, 5) = sour(cs, 5) * 10 + VAL(p$)
IF kn = 2 THEN IF sour(cs, 5) = 0 THEN sour(cs, 5) = VAL(p$)
NEXT a
NEXT B

FOR B = 4 TO delka - 1 STEP 5
kn = 0
FOR a = 1 TO LEN(u$(B))
cs = (B + 3) / 5
p$ = MID$(u$(B), a, 1)
IF p$ = ";" THEN kn = 1
IF kn = 0 THEN IF sour(cs, 6) <> 0 THEN sour(cs, 6) = sour(cs, 6) * 10 + VAL(p$)
IF kn = 0 THEN IF sour(cs, 6) = 0 THEN sour(cs, 6) = VAL(p$)
NEXT a
NEXT B

FOR B = 4 TO delka - 1 STEP 5
kn = 0
FOR a = 1 TO LEN(u$(B))
cs = (B + 3) / 5
p$ = MID$(u$(B), a, 1)
IF p$ = ";" THEN kn = 1
IF kn = 0 THEN IF sour(cs, 8) <> 0 THEN sour(cs, 8) = sour(cs, 8) * 10 + VAL(p$)
IF kn = 0 THEN IF sour(cs, 8) = 0 THEN sour(cs, 8) = VAL(p$)
NEXT a
NEXT B
                                                        'test nekorektnich'
x = 0                                                   'obektu'
nojc = 0
FOR a = 1 TO cn STEP 1
IF naz$(a) = "0" AND x = 0 THEN nojc = a - 1: x = 1
NEXT a

nojc:
IF nojc <> 0 THEN CLS : PRINT "Nalezen nekorektni objeckt v soubou "; jm$; ".dat  "
IF nojc <> 0 THEN PRINT "Obekt se jmenuje :"; naz$(nojc); " a nachazi se na "; nojc; " rakdu "
IF nojc <> 0 THEN END

                                                        'vypis seznamu obektu'                                  
FOR a = 1 TO cn
PRINT naz$(a); " -"; sour(a, 1); ","; sour(a, 2); ";"; sour(a, 3); ","; sour(a, 4); ";"; sour(a, 5); ","; sour(a, 6); ";"; sour(a, 7); ","; sour(a, 8); " "
NEXT a

PRINT
PRINT "Stiskni klavesu"
SLEEP
CLS
COLOR 10                                    'Vykresleni objektu a plochy'          
LOCATE 26, 20: PRINT "vyrobce se omlova, ale spravnost a=c a b=d se kontroluje pozdeji"
FOR o = 1 TO delka / 5
col = 13
IF o = INT(delka / 5) THEN col = 14
p = 10 + ((o - 1) * 20)
k = 4

LINE (sour(o, 1) * k + p, sour(o, 2) * k + p)-(sour(o, 3) * k + p, sour(o, 4) * k + p), col
LINE (sour(o, 3) * k + p, sour(o, 4) * k + p)-(sour(o, 5) * k + p, sour(o, 6) * k + p), col
LINE (sour(o, 5) * k + p, sour(o, 6) * k + p)-(sour(o, 7) * k + p, sour(o, 8) * k + p), col
LINE (sour(o, 1) * k + p, sour(o, 2) * k + p)-(sour(o, 7) * k + p, sour(o, 8) * k + p), col
NEXT o
COLOR 14
LOCATE 1, 20: PRINT "Plocha"
COLOR 13
LOCATE 1, 40: PRINT "Obekty"
LOCATE 25, 20: PRINT "Stiskni klavesu"
SLEEP
maxploch = 0
p = 0
CLS
PRINT "Plochy :    S="
PRINT
OPEN jm$ + ".obs" FOR OUTPUT AS #1
FOR p = 1 TO delka / 5                           'zjisti plochy'
obs(p) = sour(p, 3) * sour(p, 8)     'Dodatecne zjisteni chyby v *.dat soub.'
IF obs(p) <> sour(p, 5) * sour(p, 6) THEN nojc = p: GOTO nojc

IF p = INT(delka / 5) THEN PRINT : PRINT #1, "    ": podst = obs(p)
IF p <> INT(delka / 5) THEN celobs = celobs + obs(p): IF obs(p) > maxploch THEN maxploch = obs(p): maxobr = p
COLOR 13
PRINT naz$(p); " -"; : COLOR 14: PRINT obs(p)         'vypis na obraz'
PRINT #1, naz$(p); " -"; obs(p)       '-||-  do souboru'
NEXT p
CLOSE #1
COLOR 10
IF celobs > podst THEN PRINT "Plocha obektu je vetsi nez PLOCHA - ok"
IF celobs < podst THEN PRINT " stiskni klavesu ": SLEEP: CLS : PRINT "!!! Z obektu nejde plocha vyplnit !!!", podst, celobs: END
IF celobs = podst THEN PRINT "Plocha OBEKTU = plose PLOCHY"
PRINT
PRINT "Stiskni klavesu"
SLEEP
CLS


                                                'pripravyna plochovani'
SCREEN 13    '- 256 barev    pouzit sistem - line()-(),,B'
k = INT(200 / 30)
REM obrazec = maxobr
obrazec = 0
50
obrazec = obrazec + 1
IF obrazec = cn THEN GOTO 200
x = sour(cn, 5) / 2 * k
y = sour(cn, 6) / 2 * k
100
LINE (5, 5)-(sour(cn, 5) * k + 5, sour(cn, 6) * k + 5), 78, B


out$ = ""
'testy'
LINE (x, y)-(sour(obrazec, 5) * k + x, sour(obrazec, 6) * k + y), 0, B
LINE (x, y)-(sour(obrazec, 5) * k + x, sour(obrazec, 6) * k + y), 50, B
REM IF out$ = "" THEN GOTO 50
GOTO 100
200
END


999
PRINT "V programu nastala chyba ": SLEEP 2       'pro pripad chyby se program'
RUN                                                   '99% restartuje'