home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Loadstar 107
/
107.d81
/
quilt
(
.txt
)
< prev
next >
Wrap
Commodore BASIC
|
2022-08-26
|
11KB
|
299 lines
100 rem copyright maurice jones 1992
110 poke56,56:poke51,0:clr:dv=peek(186):ifdv<8thendv=8
120 dimi,x,y,j,k,m,mt,dv,e,j1,k1
130 sys52480,chr$(13)+"[145][157]",20,20,20,20
140 printchr$(14);chr$(8):mt=36864:box=mt+15:ce=mt+27:cm=mt:me=cm+48
150 goto1510
160 rem choice*
170 gosub220
180 fori=1tolen(ch$):ifa$=mid$(ch$,i,1)thenreturn
190 next:goto170
200 rem any key-get a$*
210 x=0:y=24:gosub240:print"[146][159] please press a key [145][145][145]"
220 geta$:ifa$=""then220:return
230 rem print at*
240 poke211,x:poke214,y:sys58732:return
250 rem select squares
260 x=5:y=3:gosub240:print"[158][146]^":k=1:j=0
270 ch$=chr$(13)+"[145][157]":gosub170:onigoto280,290,310,330,350
280 q(m)=4*j+k:print" ":return
290 ifj=0then270
300 print" ":y=y-3:gosub240:print"[146][158]^":j=j-1:goto270
310 ifj=6then270
320 print" ":y=y+3:gosub240:print"[146][158]^":j=j+1:goto270
330 ifk=1then270
340 print" ":x=x-2:gosub240:print"[146][158]^":k=k-1:goto270
350 ifk=4then270
360 print" ":x=x+2:gosub240:print"[146][158]^":k=k+1:goto270
370 rem start up
380 dimq1$(7,4),cl(14),q(16),b$(7,4),x(16),y(16),cc(14)
390 q1$(2,1)="[163]":q1$(2,2)="[164]":q1$(2,3)="[165]":q1$(2,4)="[166]"
400 q1$(3,1)="#":q1$(3,2)="$":q1$(3,3)="%":q1$(3,4)="&"
410 q1$(5,1)="[163]":q1$(5,2)="[164]":q1$(5,3)="[165]":q1$(5,4)="[166]"
420 q1$(1,1)="'":q1$(1,2)="[146][160]":q1$(1,3)=" ":q1$(1,4)="[160]"
430 b$(2,1)="[163]'[157][157][160][163]":b$(2,2)="[164][160][157][157]'[164]":b$(2,3)="[160][165][157][157][165]'":b$(2,4)="'[166][157][157][166][160]"
440 b$(3,1)="#'[157][157] #":b$(3,2)="$ [157][157]'$":b$(3,3)=" %[157][157]%'":b$(3,4)="'&[157][157]& "
450 b$(5,1)="[163]'[157][157][160][163]":b$(5,2)="[164][160][157][157]'[164]":b$(5,3)="[160][165][157][157][165]'":b$(5,4)="'[166][157][157][166][160]"
460 b$(1,1)="''[157][157]''":b$(1,2)="[160][160][157][157][160][160]":b$(1,3)=" [157][157] ":b$(1,4)="[160][160][157][157][160][160]"
470 fori=1to12:cl(i)=i-1:next:cl(13)=13:cl(14)=14
480 b $(4,1)=b $(3,1):b $(4,2)=b $(3,2):b $(4,3)=b$(3,3):b $(4,4)=b $(3,4)
490 b$(6,1)=b$(5,1):b$(6,2)=b$(5,2):b$(6,3)=b$(5,3):b$(6,4)=b$(5,4)
500 b$(7,1)=b$(5,1):b$(7,2)=b$(5,2):b$(7,3)=b$(5,3):b$(7,4)=b$(5,4)
510 k=23:fori=1to4:x(i)=k:x(i+4)=k:x(i+8)=k:x(i+12)=k:k=k+2:next
520 fori=1to4:y(i)=5:next:fori=5to8:y(i)=7:next: fori=9to12:y(i)=9:next
530 fori=13to16:y(i)=11:next
540 deffnj(x)=int((x-1)/4):deffnk(x)=x-4*(int((x-1)/4))
550 q1$(4,1)=q1$(3,1):q1$(4,2)=q1$(3,2):q1$(4,3)=q1$(3,3):q1$(4,4)=q1$(3,4)
560 q1$(6,1)=q1$(5,1):q1$(6,2)=q1$(5,2):q1$(6,3)=q1$(5,3):q1$(6,4)=q1$(5,4)
570 q1$(7,1)=q1$(5,1):q1$(7,2)=q1$(5,2):q1$(7,3)=q1$(5,3):q1$(7,4)=q1$(5,4)
580 nr(2)=1:nr(3)=3:nr(4)=6
590 fori=1to14:readcc(i):next
600 data144,5,28,159,156,30,31,158,129,149,150,151,153,154
610 rem next 3 lines define a quilt
620 data4,3,14,14,3,6,2,3,2,9,11,8,7,12,10,2,3,2,5,3,3
630 fori=1to4:readco(i):next: fori=1to16:readq(i):next:readnc
640 forj=0to2:po(j)=co(1):next:po(3)=co(2):po(4)=co(1):po(5)=co(2):po(6)=co(3)
650 return
660 rem print possible squares
670 sysbox,4,12,2,22,32,15:x=4:y=2:gosub240
680 forj=1tonr(nc)+1:poke646,po(j-1):print""; :fori=1to4:printq1$(j,i);"[146]";
690 next
700 y=y+3:gosub240:next
710 return
720 rem colors-move cursor
730 x=6:y=4:gosub240:print"[158]^":k=1:j=0
740 ch$=chr$(13)+"[145][157]d" :gosub170:onigoto750,760,780,800,820,1100
750 co(m)=cl(2*j+k):print" ":return
760 ifj=0then740
770 print" ":y=y-3:gosub240:print"^":j=j-1:goto740
780 ifj=6then740
790 print" ":y=y+3:gosub240:print"^":j=j+1:goto740
800 ifk=1then740
810 print" ":x=x-4:gosub240:print"^":k=1:goto740
820 ifk=2then740
830 print" ":x=x+4:gosub240:print"^":k=2:goto740
840 rem screen
850 print"[147]":poke53272,31:poke198,0
860 poke53265,peek(53265)or64:poke53281,15:poke53280,09
870 sysbox,0,39,0,24,0,08:sysbox,3,13,1,23,32,15:sysbox,3,3,1,23,63,08
880 sysbox,13,13,1,23,61,08:sysbox,21,32,3,14,32,15:sysbox,21,21,3,14,63,08
890 sysbox,32,32,3,14,61,08:sysbox,18,35,17,21,32,15:sysbox,18,35,17,17,60,08
900 sysbox,18,35,21,21,62,08:
910 poke646,8:x=18:y=17:gosub240:print"[[157]?[157]?[157]?[157]*"
920 poke646,8:x=35:y=17:gosub240:print"][157]=[157]=[157]=[157]+"
930 x=03:y=23:gosub240:print"*>>>>>>>>>+"
940 x=03:y=1:gosub240:poke646,08:print"[<<<<<<<<<]
950 x[178]21:y[178]3:[141]240:[151]646,08:[153]"[<<<<<<<<<<]
960 x=21:y=14:gosub240:print"*>>>>>>>>>>+"
970 return
980 rem print color squares
990 x=6:y=3:gosub240:forj=0to 6:fori=1to2:poke646,cl(2*j+i):print"'";:next
1000 y=y+3:gosub240:next:return
1010 rem print a block
1020 poke646,co(1):poke53282,co(2):poke53283,co(3):poke53284,co(4)
1030 w=0:form1=0to3:forn=0to3:w=w+1:j=fnj(q(w)):k=fnk(q(w))
1040 ifj<0then1060
1050 poke646,po(j):print"[146]" b$(j+1,k);"[146][145]";
1060 next
1070 print"[157][157][157][157][157][157][157][157]";:next:print"[145][145]";
1080 return
1090 rem a patch on sub250!
1100 onmgoto740,740,1110,1120
1110 co(3)=co(2):co(4)=co(2):nc=2:return
1120 co(4)=co(3):nc=3: m=4:return
1130 rem draw grid
1140 poke646,00
1150 x=23:y=5:gosub240:print"\][][][][157][157][157][157][157][157][157][157]*+*+*+*+[157][157][157][157][157][157][157][157][][][][][157][157][157][157][157][157][157][157]";
1160 print"*+*+*+*+[157][157][157][157][157][157][157][157][][][][][157][157][157][157][157][157][157][157]";
1170 print"*+*+*+*+[157][157][157][157][157][157][157][157][][][][][157][157][157][157][157][157][157][157]";
1180 print"*+*+*+*+[157][157][157][157][157][157][157][157]"; :return
1190 rem disk directory
1200 poke53272,21
1210 print"[158][147]":sysmt+51,"$:"+"q.*",dv:open15,8,15: gosub1970:ife<20then1230
1220 print"[158] drive error":print:print:print"";e;e$;t;s
1230 close15:gosub210:goto1520
1240 remsave
1250 print"[147]":poke53272,23:fori=1to16:ifq(i)<1orq(i)>28then 1330:next
1260 close15:close3:iff$=""then1262
1261 print"[147]save as "f$"? (y/n)":sysmt+45,"yn":iff%=1then1268
1262 print:print"filename: ";:syscm+66,1,13,20:ifw$=""then1520
1264 f$=w$
1268 ifleft$(f$,2)<>"q."thenf$="q."+f$
1269 q9$=f$:close15:open15,dv,15,"s:"+f$:open2,dv,2,q9$+",p,w"
1270 fori=1to4:print#2,co(i):next:fori=1to16:print#2,q(i):next:print#2,nc
1280 gosub1970:print"[146][159]
1290 [139]e[179]20[167]1310:[153]"waitopen"
1300 [153]:[153]"save failed":[153]:[153]e;e$;t;s:[137]1320
1310 [153]:[153]"sys "q9$" saved"
1320 [160]2:[160]15: [141]210:[137]1520
1330 [160]2:[160]15:[137]1520
1340 [143] load
1350 [158]box,0,39,3,21,102,10:[151]53272,23:[141]3050
1355 [158]cm[170]42,"i0",dv:[139][197](e$)[167]1359
1357 ms$[178]"chr$etting directory...":[141]3000:[158]mt[170]6,"$:q.*",dv,53248
1358 [139]f%[178]0[167]ms$[178]"(NULL)o quilts on this disk":[141]3030:[137]1520
1359 [139][197](e$)[167]ms$[178]e$:[141]3030:[137]1520
1360 ms$[178]"(NULL)lease select quilt":[141]3000:[158]cm[170]72,10,29,5,19
1362 [158]cm[170]3,11,4,11,3,1:[139]f$[178]""[167]1530
1369 q9$[178]f$:[160]3:[159]3,dv,3,q9$[170]",p,r"
1370 [129]i[178]1[164]4:[132]3,co(i):[130]:[129]i[178]1[164]16:[132]3,q(i):[130]:[132]3,nc
1380 [160]3:[158]cm[170]42,"",dv:[139][197](e$)[167]ms$[178]e$:[141]3030:[137]1520
1410 [137]1450
1420 [151]53265,[194](53265)[176]64:[151]53281,15:[151]53280,09
1430 [129]j[178]0[164]2:po(j)[178]co(1):[130]:po(3)[178]co(2):po(4)[178]co(1):po(5)[178]co(2):po(6)[178]co(3)
1440 [141]850:[137]1860
1450 [129]i[178]1[164]16:[139]q(i)[179]1[176]q(i)[177]28[167]1470
1460 [130]: [137]1420
1470 [153]" sys this is not a quilt":[141]210:[137]1520
1480 [143] instructions
1490 [151]53272,21:[153][199](14):[158]mt[170]51,"t.instructions",dv
1500 [151]53272,31:[137]1520
1510 [141]380
1520 [151]53265,[194](53265)[175]191:[151]53280,0:[151]53281,0:[151]646,3:[151]198,0
1530 [153]"load":[151]53272,31:y[178]7:[158]box,0,39,3,21,0,10:[158]box,0,39,0,0,121,8
1532 [158]box,0,39,1,1,160,10:[158]box,0,39,2,2,120,2
1534 [153]"def";:[158]ce,1,"(NULL)closeatn (NULL) len left$ (NULL) (NULL) (NULL) (NULL) (NULL) (NULL) right$ (NULL) (NULL)"
1536 [158]box,0,39,23,23,160,10:[158]box,0,39,24,24,120,2:[158]box,0,39,22,22,121,8
1538 [158]ce,23,"len(NULL)(NULL)(NULL)/(NULL)val(NULL)(NULL)(NULL)(NULL) (NULL)(NULL)closemid$(N