'WendelSoft Dominox 1.0
'Copyright 2000(c)WendelSoft
'11.06.00-12.06.00
'Wendel Scardua
'-----------------------------
DECLARE SUB Box(l%,c%)
DECLARE SUB Cursor(i%,j%)
DECLARE SUB NewSeq(n%,n$,l%,c%,Dir%)
DECLARE SUB Position(i%)
DECLARE SUB QuickSort(array()AS ANY,left%,right%)
DECLARE FUNCTION Equal%(a$,b$)
DECLARE FUNCTION IsDigit%(k$)
'$DYNAMIC
TYPE numlt
Number AS STRING*12
Lin AS INTEGER
Col AS INTEGER
Dir AS INTEGER
END TYPE
KEY(1)ON
ON KEY(1)GOSUB fim
DEFINT A-Z
RANDOMIZE TIMER
VIEW ?1 TO 25
CLS
?"Definir teclas:"
?"P/ cima :";:DO:kup$=INKEY$:LOOP WHILE kup$="":?"Ok"
?"P/ baixo :";:DO:kdown$=INKEY$:LOOP WHILE kdown$="":?"Ok"
?"P/ direita :";:DO:kright$=INKEY$:LOOP WHILE kright$="":?"Ok"
?"P/ esquerda :";:DO:kleft$=INKEY$:LOOP WHILE kleft$="":?"Ok"
?"P/ usar lista :";:DO:klist$=INKEY$:LOOP WHILE klist$="":?"Ok"
?"P/ riscar item :";:DO:kitem$=INKEY$:LOOP WHILE kitem$="":?"Ok"
DO
CLS
?"WendelSoft Dominox 1.0"
?
DO
INPUT "Quantidade de numeros (5-35) :",qtd
LOOP UNTIL qtd>=5 AND qtd<=35
DO
INPUT "Minimo de digitos (3-12) :",Min
LOOP UNTIL Min>=3 AND Min<=12
DO
?USING "Maximo de digitos (##_-12) :";Min;
INPUT "",Max
LOOP UNTIL Max>=Min AND Max<=12
DO
?USING "Largura (##_-20) :";Min;
INPUT "",Larg
LOOP UNTIL Larg>=Min AND Larg<=20
IF Larg>=Max THEN Lim=Min ELSE Lim=Max
DO
?USING "Altura (##_-12) :";Lim;
INPUT "",Alt
LOOP UNTIL Alt>=Min AND Alt<=12
DIM Scr(1 TO Alt,1 TO Larg)AS STRING*1,NumList(1 TO qtd)AS numlt,chk(1 TO qtd)
FOR l=1 TO Alt:FOR c=1 TO Larg
Scr(l,c)=" "
NEXT c,l
FOR v=1 TO qtd
1 n=INT(RND*(Max-Min+1))+Min
n$=SPACE$(n)
Dir=INT(RND*2)
IF Dir THEN
IF n>Larg THEN Dir=0
ELSE
IF n>Alt THEN Dir=1
END IF
ct=0
IF Dir THEN
DO
DO
IF ct=15 GOTO 1
l=INT(RND*Alt)+1
c=INT(RND*(Larg-n+1))+1
tt=0
tt2=0
FOR i=c TO c+n-1
tt=tt-(Scr(l,i)=" ")
tt2=tt2-(Scr(l,i)="#")
NEXT
ct=ct+1
tt3=0
IF c>1 THEN tt3=IsDigit(Scr(l,c-1))
IF c+n-1<Larg THEN tt3=tt3 OR IsDigit(Scr(l,c+n))
LOOP WHILE(tt=n AND v>1)OR tt2>0 OR tt3
FOR r=1 TO v-1
IF NumList(r).Dir THEN
cot=NumList(r).Col
lit=NumList(r).Lin
tm=LEN(RTRIM$(LTRIM$(NumList(r).Number)))
IF c+n>cot AND c<cot+tm AND l=lit THEN EXIT FOR
END IF
NEXT
LOOP WHILE r<v
NewSeq n,n$,l,c,Dir
FOR i=c TO c+n-1
Scr(l,i)=MID$(n$,i-c+1,1)
NEXT
IF c>1 THEN Scr(l,c-1)="#"
IF c+n-1<Larg THEN Scr(l,c+n)="#"
ELSE
DO
DO
IF ct=15 GOTO 1
l=INT(RND*(Alt-n+1))+1
c=INT(RND*Larg)+1
tt=0
tt2=0
FOR i=l TO l+n-1
tt=tt-(Scr(i,c)=" ")
tt2=tt2-(Scr(i,c)="#")
NEXT
ct=ct+1
tt3=0
IF l>1 THEN tt3=IsDigit(Scr(l-1,c))
IF l+n-1<Alt THEN tt3=tt3 OR IsDigit(Scr(l+n,c))
LOOP WHILE(tt=n AND v>1)OR tt2>0 OR tt3
FOR r=1 TO v-1
IF NumList(r).Dir=0 THEN
cot=NumList(r).Col
lit=NumList(r).Lin
tm=LEN(RTRIM$(LTRIM$(NumList(r).Number)))
IF l+n>lit AND l<lit+tm AND c=cot THEN EXIT FOR
END IF
NEXT
LOOP WHILE r<v
NewSeq n,n$,l,c,Dir
FOR i=l TO l+n-1
Scr(i,c)=MID$(n$,i-l+1,1)
NEXT
IF l>1 THEN Scr(l-1,c)="#"
IF l+n-1<Alt THEN Scr(l+n,c)="#"
END IF
NumList(v).Number=RIGHT$(SPACE$(12)+n$,12)
NumList(v).Lin=l
NumList(v).Col=c
NumList(v).Dir=Dir
NEXT
QuickSort NumList(),1,qtd
CLS
FOR l=1 TO Alt:FOR c=1 TO Larg
Box 2*l,2*c
IF Scr(l,c)="#" THEN Scr(l,c)=" "
IF Scr(l,c)<>" " THEN LOCATE 2*l,2*c:?" ";
NEXT c,l
FOR i=1 TO qtd
Position i:?LTRIM$(RTRIM$(NumList(i).Number));
NEXT
numtot=1
n$=LTRIM$(RTRIM$(NumList(qtd).Number))
COLOR 0,7:Position qtd:?n$;:COLOR 7,0
n=LEN(n$)
li=NumList(qtd).Lin
co=NumList(qtd).Col
IF NumList(qtd).Dir THEN
FOR j=co TO co+n-1
LOCATE 2*li,2*j:?MID$(n$,j-co+1,1);
NEXT
ELSE
FOR j=li TO li+n-1
LOCATE 2*j,2*co:?MID$(n$,j-li+1,1);
NEXT
END IF
l=1:c=1
bk$=CHR$(SCREEN(2*l,2*c))
COLOR 15,0:Box 2*l,2*c:COLOR 7,0
LOCATE 2*l,2*c:?bk$;
DO
FOR i=1 TO qtd
li=NumList(i).Lin
co=NumList(i).Col
IF NumList(i).Dir THEN
LOCATE 2*li,2*co-1:?CHR$(26)
ELSE
LOCATE 2*li-1,2*co:?CHR$(25);
END IF
NEXT
al=l:ac=c
b$=INKEY$
SELECT CASE b$
CASE kup$:l=l-1:IF l=0 THEN l=Alt
CASE kdown$:l=l+1:IF l>Alt THEN l=1
CASE kleft$:c=c-1:IF c=0 THEN c=Larg
CASE kright$:c=c+1:IF c>Larg THEN c=1
CASE klist$
p=1
DO
Cursor p,1
SELECT CASE INKEY$
CASE kup$:Cursor p,0:p=p-1:IF p=0 THEN p=qtd
CASE kdown$:Cursor p,0:p=p+1:IF p>qtd THEN p=1
CASE kitem$
chk(p)=NOT chk(p)
IF chk(p)THEN COLOR 0,7
Position p:?LTRIM$(RTRIM$(NumList(p).Number));:COLOR 7,0
CASE klist$:Cursor p,0:EXIT DO
END SELECT
LOOP
CASE "0" TO "9"
IF bk$<>CHR$(219)THEN
bk$=b$
LOCATE 2*l,2*c:?b$;
numtot=0
FOR v=1 TO qtd
n$=LTRIM$(RTRIM$(NumList(v).Number))
n=LEN(n$)
li=NumList(v).Lin
co=NumList(v).Col
IF NumList(v).Dir THEN
FOR j=co TO co+n-1
IF MID$(n$,j-co+1,1)<>CHR$(SCREEN(2*li,2*j))THEN EXIT FOR
NEXT
IF j=co+n THEN numtot=numtot+1
ELSE
FOR j=li TO li+n-1
IF MID$(n$,j-li+1,1)<>CHR$(SCREEN(2*j,2*co))THEN EXIT FOR
NEXT
IF j=li+n THEN numtot=numtot+1
END IF
NEXT
END IF
CASE CHR$(27):EXIT DO
END SELECT
IF l<>al OR c<>ac THEN
Box 2*al,2*ac
LOCATE 2*al,2*ac:?bk$;
bk$=CHR$(SCREEN(2*l,2*c))
COLOR 15,0:Box 2*l,2*c:COLOR 7,0
LOCATE 2*l,2*c:?bk$;
END IF
LOOP UNTIL numtot=qtd
IF numtot=qtd THEN PLAY "MFl16o4cdefdefgefgafgab"
k$=INPUT$(1)
CLS
?"Continua [S/N] ? ";
DO:k$=UCASE$(INPUT$(1)):LOOP UNTIL k$="S" OR k$="N"
?k$:BEEP
ERASE NumList,Scr,chk
LOOP UNTIL k$="N"
?
fim:
SYSTEM
REM $STATIC
SUB Box(l,c)
SHARED Larg,Alt
IF l=2 THEN
IF c=2 THEN
k$=CHR$(218)+CHR$(196)+CHR$(194)
w$=CHR$(179)+CHR$(219)+CHR$(179)
y$=CHR$(195)+CHR$(196)+CHR$(197)
ELSEIF c=2*Larg THEN
k$=CHR$(194)+CHR$(196)+CHR$(191)
w$=CHR$(179)+CHR$(219)+CHR$(179)
y$=CHR$(197)+CHR$(196)+CHR$(180)
ELSE
k$=CHR$(194)+CHR$(196)+CHR$(194)
w$=CHR$(179)+CHR$(219)+CHR$(179)
y$=CHR$(197)+CHR$(196)+CHR$(197)
END IF
ELSEIF l=2*Alt THEN
IF c=2 THEN
k$=CHR$(195)+CHR$(196)+CHR$(197)
w$=CHR$(179)+CHR$(219)+CHR$(179)
y$=CHR$(192)+CHR$(196)+CHR$(193)
ELSEIF c=2*Larg THEN
k$=CHR$(197)+CHR$(196)+CHR$(180)
w$=CHR$(179)+CHR$(219)+CHR$(179)
y$=CHR$(193)+CHR$(196)+CHR$(217)
ELSE
k$=CHR$(197)+CHR$(196)+CHR$(197)
w$=CHR$(179)+CHR$(219)+CHR$(179)
y$=CHR$(193)+CHR$(196)+CHR$(193)
END IF
ELSEIF c=2 THEN
k$=CHR$(195)+CHR$(196)+CHR$(197)
w$=CHR$(179)+CHR$(219)+CHR$(179)
y$=CHR$(195)+CHR$(196)+CHR$(197)
ELSEIF c=2*Larg THEN
k$=CHR$(197)+CHR$(196)+CHR$(180)
w$=CHR$(179)+CHR$(219)+CHR$(179)
y$=CHR$(197)+CHR$(196)+CHR$(180)
ELSE
k$=CHR$(197)+CHR$(196)+CHR$(197)
w$=CHR$(179)+CHR$(219)+CHR$(179)
y$=CHR$(197)+CHR$(196)+CHR$(197)
END IF
LOCATE l-1,c-1:?k$;
LOCATE l,c-1:?w$;
LOCATE l+1,c-1:?y$;
'FOR i=l-1 TO l+1
'LOCATE i,c-1:?STRING$(3,219);
'NEXT
END SUB
SUB Cursor(i,j)
LOCATE(i-1)MOD 20+1,43+20*((i-1)\20)
IF j THEN ?"->";ELSE ?"  ";
END SUB
FUNCTION Equal(a$,b$)
Equal=(a$=" " OR b$=" " OR a$=b$)
END FUNCTION
FUNCTION IsDigit(k$)
IsDigit=(INSTR("0123456789",k$)>0)
END FUNCTION
SUB NewSeq(n,n$,l,c,Dir)
SHARED Scr()AS STRING*1
IF Dir THEN
FOR i=c TO c+n-1
DO
k$=MID$(n$,i-c+1,1)
w$=Scr(l,i)
IF k$<>" " THEN
IF k$=w$ XOR(w$=" ")THEN EXIT DO
END IF
MID$(n$,i-c+1,1)=RIGHT$(STR$(INT(RND*10)),1)
LOOP
NEXT
ELSE
FOR i=l TO l+n-1
DO
k$=MID$(n$,i-l+1,1)
w$=Scr(i,c)
IF k$<>" " THEN
IF k$=w$ XOR(w$=" ")THEN EXIT DO
END IF
MID$(n$,i-l+1,1)=RIGHT$(STR$(INT(RND*10)),1)
LOOP
NEXT
END IF
END SUB
SUB Position(i)
LOCATE(i-1)MOD 20+1,45+20*((i-1)\20)
END SUB
REM $DYNAMIC
SUB QuickSort(array()AS numlt,left,right)
i=left:j=right:test$=array((left+right)\2).Number
DO
WHILE(array(i).Number<test$):i=i+1:WEND
WHILE(test$<array(j).Number):j=j-1:WEND
IF i<=j THEN
SWAP array(i),array(j)
i=i+1
j=j-1
END IF
LOOP WHILE i<=j
IF left<j THEN QuickSort array(),left,j
IF i<right THEN QuickSort array(),i,right
END SUB