-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathFIGGEN.BAS
168 lines (168 loc) · 5.38 KB
/
FIGGEN.BAS
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
2 ' Generador de figuras fijas
10 '
20 KEY OFF:COLOR 3,1,1:SCREEN 0,,1:CLS:CLEAR 200,49999!
22 ON ERROR GOTO 6000
25 CF=3:CT=1:MD=1:SI=0
26 LOCATE 0,8
30 PRINT" 1-GENERADOR DE FIGURAS"
40 PRINT" 2-CARGAR FIGURA DE DISCO"
45 PRINT" 3-PRUEBA"
46 PRINT" 4-CAMBIO COLORES"
50 A$=INKEY$
60 IF A$="1" THEN 1000
70 IF A$="2" THEN 3500
75 IF A$="3" THEN 4000
76 IF A$="4" THEN 5000
80 GOTO 50
1000 ' generador de figuras fijas
1010 SCREEN 0:COLOR 3,1,1:KEY OFF:CLS
1016 PRINT:PRINT" GENERADOR DE FIGURAS":PRINT:PRINT:PRINT" Introduzca los datos en baja":PRINT:PRINT" resolucion (bloques de 8*8)."
1020 LOCATE 6,10:INPUT"¨Ancho de la figura ";AX:IF AX<1 OR AX>6 THEN 1020
1030 LOCATE 6,12:INPUT"¨Alto de la figura ";AY:IF AY<1 OR AY>6 THEN 1030
1040 AX=AX*8
1050 AY=AY*8
1060 SCREEN 5,,0:GOSUB 1900
1070 FOR F=1 TO AY
1080 FOR G=1 TO AX
1090 LINE(G*4,F*4)-(G*4+2,F*4+2),,BF
1100 NEXT G:NEXT F
1110 X=1:Y=1:FLAG=0
1115 ON KEY GOSUB 1300,1400,,1800,1700,3000,,,10,:KEY(1) ON:KEY(2) ON:KEY(4) ON:KEY(5) ON:KEY(6) ON:KEY(9) ON
1120 A=STICK(0)
1125 IF STRIG(0)<>O THEN GOSUB 1600
1126 GOSUB 2000
1127 IF A=0 THEN 1120
1130 IF A>=2 AND A<=4 AND X<AX THEN X=X+1
1140 IF A>=6 AND A<=8 AND X>1 THEN X=X-1
1150 IF A>=4 AND A<=6 AND Y<AY THEN Y=Y+1
1160 IF (A=8 OR A=1 OR A=2) AND Y>1 THEN Y=Y-1
1170 IF MD<>1 THEN GOSUB 1600
1200 GOTO 1120
1300 BEEP:FOR F=X TO 1 STEP -1
1310 IF POINT(F*4,Y*4)=1 THEN BEEP:RETURN
1320 LINE(F*4,Y*4)-(F*4+2,Y*4+2),1,BF:PSET(200+F,20+Y),CT
1330 NEXT F:BEEP
1390 RETURN
1400 BEEP:FOR F=X TO AX
1410 IF POINT(F*4,Y*4)=1 THEN BEEP:RETURN
1420 LINE(F*4,Y*4)-(F*4+2,Y*4+2),1,BF:PSET(200+F,20+Y),CT
1430 NEXT F:BEEP
1490 RETURN
1600 IF MD=2 OR MD=1 AND POINT(X*4,Y*4)=3 THEN LINE(X*4,Y*4)-(X*4+2,Y*4+2),1,BF:PSET (200+X,20+Y),CT:IF SI=1 THEN LINE((AX-X+1)*4,Y*4)-STEP(2,2),1,BF:PSET (200+AX-X+1,20+Y),CT ELSE GOTO1620:GOTO1620
1610 IF MD=3 OR MD=1 AND POINT(X*4,Y*4)=1 THEN LINE(X*4,Y*4)-(X*4+2,Y*4+2),3,BF:PSET (200+X,20+Y),CF:IF SI=1 THEN LINE((AX-X+1)*4,Y*4)-STEP(2,2),3,BF:PSET (200+AX-X+1,20+Y),CF
1620 IF STRIG(0)<>0 THEN 1620
1630 RETURN
1700 ' simetria on/off
1705 BEEP
1710 SI=SI+1:IF SI=2 THEN SI=0
1720 IF SI=0 THEN COLOR 8:PSET(224,142):PRINT#1,"SIM"
1730 IF SI=1 THEN COLOR 4:PSET(224,142):PRINT#1,"SIM"
1740 RETURN
1800 'cambio modo
1805 COLOR 4:BEEP
1810 MD=MD+1:IF MD=4 THEN MD=1
1820 IF MD=1 THEN A$="MOV"
1830 IF MD=2 THEN A$="DIB"
1840 IF MD=3 THEN A$="BOR"
1850 PSET(224,132):PRINT#1,A$
1855 COLOR 3
1860 RETURN
1900 ' instrucciones
1905 COLOR 8
1907 CLOSE:OPEN"grp:" FOR OUTPUT AS#1
1910 LINE (197,96)-(252,153),14,B
1915 LINE (197,157)-(252,212),5,B
1916 LINE (8,196)-(193,212),4,B
1930 PSET (200,102):PRINT#1,"F1 IZQ"
1940 PSET (200,112):PRINT#1,"F2 DER"
1950 PSET (200,122):PRINT#1,"F3 ---"
1951 PSET (200,132):PRINT#1,"F4"
1952 PSET (200,142):PRINT#1,"F5 SIM"
1953 PSET (200,162):PRINT#1,"F6 SAV"
1954 PSET (200,172):PRINT#1,"F7 ---"
1955 PSET (200,182):PRINT#1,"F8 ---"
1956 PSET (200,192):PRINT#1,"F9 NEW"
1957 PSET (200,202):PRINT#1,"F10 --"
1958 COLOR 4:PSET(224,132):PRINT#1,"MOV"
1960 LINE (197,17)-(252,92),CF,BF
1980 COLOR 3
1990 RETURN
2000 'cursor
2010 LINE(X*4-1,Y*4-1)-(X*4+3,Y*4+3),9,B
2020 FOR F=1 TO 20:NEXT
2030 LINE(X*4-1,Y*4-1)-(X*4+3,Y*4+3),1,B
2040 RETURN
3000 'save
3010 DIR=50000!
3015 POKE DIR,AX/8:POKE DIR+1,AY/8:DIR=DIR+2
3020 FOR F=1 TO AY STEP 8
3030 FOR G=1 TO AX/8
3031 FOR J=0 TO 7:A$=""
3035 FOR H=1 TO 8
3040 IF POINT((G*8+H-8)*4,(F+J)*4)=3 THEN B$="0" ELSE B$="1"
3050 A$=A$+B$
3055 NEXT H:POKE DIR,VAL("&B"+A$)
3056 DIR=DIR+1
3060 NEXT J:NEXT G:NEXT F
3070 SCREEN 0,,1:CLS
3080 FILES"*.FIG"
3085 PRINT:PRINT
3090 INPUT "Nombre del archivo";NO$
3100 PA$="A:"+LEFT$(NO$,8)+".fig"
3110 BSAVE PA$,50000!,(50000!+(AX+AY*8+2))
3200 GOTO10
3500 ' load para correcciones
3510 SCREEN 0:COLOR 3,1,1:CLS
3520 FILES"*.fig":PRINT
3530 INPUT"¨Nombre del archivo";NO$
3540 PA$="A:"+NO$+".fig"
3550 BLOAD PA$
3555 SCREEN5,,0:COLOR 3
3556 GOSUB 1900
3560 AX=8*PEEK(50000!):AY=8*PEEK(50001!)
3570 DIR=50002!
3580 FOR F=0 TO (AY/8-1)
3590 FOR G=0 TO (AX/8-1)
3605 FOR L=1 TO 8
3606 D$="00000000"+BIN$(PEEK(DIR)):D$=RIGHT$(D$,8)
3610 FOR H=1 TO 8
3620 IF MID$(D$,H,1)="0" THEN LINE ((G*8+H)*4,(F*8+L)*4)- STEP(2,2),,BF ELSE PSET (200+G*8+H,20+F*8+L),CT
3630 NEXT H:DIR=DIR+1:NEXT L:NEXT G:NEXT F
3650 GOTO 1110
3999 ' load y lo representa
4000 SCREEN 0:COLOR 3,1,1:CLS
4010 FILES"*.fig":PRINT
4020 INPUT"¨Nombre del archivo";NO$
4030 PA$="A:"+NO$+".fig"
4040 BLOAD PA$
4050 SCREEN2
4060 DIR=50002!
4070 FOR F=1 TO PEEK(50001!)
4080 FOR G=1 TO PEEK(50000!)
4085 FOR H=0 TO 7
4090 VDIR=(F*256)+G*8+H+32
4100 VPOKE VDIR,PEEK(DIR)
4110 VPOKE VDIR+8192,(CF*16+CT)
4120 DIR=DIR +1:CH=CH+8
4130 NEXT H:NEXT G:NEXT F
4140 IF INKEY$="" THENGOTO 4140
4150 GOTO 10
5000 ' CAMBIO COLORES
5010 COLOR 5,1,1:SCREEN2
5020 INPUT"Color para el fondo";CF
5030 INPUT"Color para la figura";CT
5040 COLOR 3:CLS:GOTO30
6000 ' errores
6010 IF ERR=66 THEN ER$="Disco lleno"
6020 IF ERR=690 THEN ER$="Error I/O"
6030 IF ERR=70 THEN ER$="No hay disco"
6040 IF ERR=68 THEN ER$="Disco protegido"
6050 IF ERR=53 THEN ER$="No existe fichero "+NO$
6060 IF ERR=56 THEN ER$="Nombre incorrecto"
6065 PLAY"S10M1000ABC","S10M1000CDE","O3FGA"
6070 SCREEN 0:COLOR 15,6,6
6080 CX=(37-LEN(ER$))/2
6090 LOCATE CX,10:PRINT ER$:N$=SPACE$(12):FOR F=1 TO 1000:NEXT
6100 SCREEN 5:RESUME 6110
6110 GOTO 10