64'er Special 12/64er_Magazin_Sonderheft_12_86-12_1986_Markt__Technik_de_Side_A.d64/flash-sort.src

Commodore BASIC | 2022-10-26 | 15KB | 765 lines

100 sys 9*4096
101 .opt p,oo
102 *= $cb20 ;sys 52000
103 ;
104 ;---------------------------------------
105 ;--------- quelltext flashsort ---------
106 ;---------------------------------------
107 ;
108 term = $ad9e
109 stest = $a3fb
110 komma = $aefd
111 chr(NULL)t = $0079
112 type = $6d
113 rund = $6e
114 numfl = $6f
115 ;
116 ;------ speicherstellen zeropage -------
117 ;------ nur eindimensional/string ------
118 ;
119 ;-------------- hauptarray -------------
120 ;
121 ;$fb/$fc = hauptarray anfang
122 ;$fd/$fe = hauptarray ende+1
123 ;$22/$23 = a-element hauptarray
124 ;$71/$72 = b-element
125 ;$24/$25 = b-element(einsortieren)
126 ;$26/$27 = teilfeld anfang
127 ;$55/$56 = ende+1 des teilfeldes
128 ;$5b-$5d = deskriptor a-element
129 ;$5e-$60 = deskriptor b-element
130 ;$69/$6a = schrittweite
131 ;  $6d   = platzbedarf(2,3 oder 5)
132 ;  $6e   = rundungsbyte beim
133 ;          halbieren der schritt-
134 ;          weite;integer benoetigt
135 ;          sonderbehandlung
136 ;  $6f   = flag num./stringarray
137 ;          num.=0 string=$ff
138 ;
139 ;-------------- nebenarray -------------
140 ;
141 ;$57/$58 = anfang
142 ;$59/$5a = ende+1
143 ;$61/$62 = a-element
144 ;$4b/$4c = b-element
145 ;$63/$64 = b-element(einsortieren)
146 ;$28/$29 = teilfeldbeginn
147 ;          (teilfeldende unnoetig)
148 ;$6b/$6c = schrittweite
149 ;  $14   = platzbedarf(2,3 oder 5)
150 ;  $15   = rundungsbyte
151 ;          wie $6d/$6e hauptarray
152 ;---------------- start ----------------
153 ;
154 lda #3;stack auf
155 jsr stest;6 byte testen
156 jsr array;1.array holen
157 txa
158 pha;typ merken
159 ldx #3
160 setar lda $57,x;arraygrenzen
161 sta $fb,x;hauptarray
162 dex
163 bpl setar
164 inx
165 lda flag1;2 dim.array
166 beq setar1;nein
167 lda flag;ja,test auf teil-
168 php;bereich;wenn ja
169 beq normal;ende und anzahl
170 stx flag1;elemente 2.dim.
171 jsr arr3;holen
172 normal jsr platz
173 sta $62;ges.platz divid.
174 stx $63;durch anzahl
175 ldx #$90;elemente 2.dim.
176 sec; = offset auf
177 jsr $bc49;das 1.element
178 jsr $bc0c;der 2.dimension
179 ldy flag1
180 beq fehlf
181 jsr $b3a2
182 lda $61
183 jsr $bb12
184 jsr $b7f7
185 sty ol;offset low
186 sta oh;offset high
187 tax
188 tya
189 clc
190 adc $57
191 tay
192 txa
193 adc $58
194 plp;nur teilarray
195 beq setara;nein
196 cmp $fe;test,ob angabe
197 bcc fehlf;1.element der
198 bne setar0;2.dimens. =0!
199 cpy $fd;wenn nein,fehler
200 bcs setar0
201 fehlf jmp fehler
202 setara sta $fe;ganzes array
203 sty $fd;ende neu setzen
204 ;---------------------------------------
205 setar0 ldx #0;default fuer
206 setar1 stx $14;kein 2.array
207 jsr chr(NULL)t
208 beq del
209 jsr arr1;2.array holen
210 txa;platzbedarf nach
211 sta $14;$14 und
212 lsr;rundungsbyte
213 bcs setr;berechnen
214 lda #$ff;-integer-
215 setr sta $15;nebenarray
216 txa;startschrittweite
217 asl;auf 511 elemente
218 tax;high=platz*2-1
219 dex
220 stx $6c
221 lda #0;low=256-platz
222 sec
223 sbc $14
224 sta $6b
225 jsr gplatz
226 pla;test auf gleiche
227 pha;anzahl von
228 jsr test;elementen
229 ;---------------------------------------
230 del ldy #0;defaultwert
231 sty $2a;numer.array
232 pla;fuer mitsortieren
233 sta type
234 cmp #3;numer.array
235 beq del0;nein
236 ldx flag1;ja,test auf
237 bne fehlf;eindimensional
238 beq start0
239 ;---------------------------------------
240 del0 lda $fd;leerstrings
241 ldx $fe;am ende des
242 del1 sec;arrays entfernen
243 sbc #3;nur wenn haupt-
244 bcs del2;array string
245 dex
246 del2 sta $55
247 stx $56
248 lda ($55),y
249 bne start;kein leerstring
250 lda $59;nebenarray
251 sec;verkleinern
252 sbc $14
253 sta $59
254 bcs del3
255 dec $5a
256 del3 stx $fe;hauptarray
257 lda $55;verkleinern
258 sta $fd
259 cmp $fb;test ob array-
260 bne del1;anfang schon
261 cpx $fc;erreicht ist
262 bne del1;nein,weitermachen
263 ;
264 rts;****** ende ******
265 ;                     *nur leerstrings *
266 ;------------ sortierbeginn ------------
267 ;
268 start lda type;
269 dey;string=$ff
270 start0 sty numfl;num.=0
271 lsr;rundungsbyte
272 bcs start1;berechnen
273 lda #$ff;--integer
274 start1 sta rund
275 lda type
276 asl;startschritt-
277 tax;weite auf 511
278 dex;elemente setzen
279 lda #0;(wie oben)
280 sec
281 sbc type
282 sta $69
283 stx $6a
284 lda 53280;rahmenfarbe
285 pha;merken
286 ;---------------------------------------
287 big lsr $6a;schrittweite
288 lda $69;halbieren
289 ror;start mit 255 elem.
290 bit rund;test auf integer
291 bvc biga;nein
292 and #$fe;ja,bit 0 loeschen
293 clc;und kein uebertrag
294 biga bcc bigb
295 sbc rund
296 bigb tax
297 bne big1
298 pla
299 sta 53280
300 rts;****** ende ******
301 big1 sta $69
302 inc 53280;blinken
303 clc
304 lda $fb;teilfeldstart
305 tax;=arrayanfang
306 adc $69;low in x-reg
307 sta $55;high in y-reg
308 lda $fc;+schrittw.
309 tay;=teilfeldende
310 adc $6a
311 sta $56
312 lda $14
313 beq set3
314 lsr $6c;schrittweite
315 lda $6b;nebenarray
316 ror;halbieren
317 bit $15;test auf integer
318 bvc big2;nein
319 and #$fe;ja,bit 0 loeschen
320 clc;und kein uebertrag
321 big2 bcc big3
322 sbc $15
323 big3 sta $6b
324 lda $57
325 sta $4b
326 sta $28
327 lda $58
328 bne set2a;unbedingter sprung
329 ;---------------------------------------
330 set lda $26;naechstes teilfeld
331 ldy $27;bearbeiten
332 clc
333 adc type
334 tax
335 bcc set1
336 iny
337 set1 cmp $55;wenn alle teil-
338 bne set2;felder sortiert,
339 cpy $56;dann schrittweite
340 beq big;halbieren
341 set2 lda $14
342 beq set3
343 clc
344 adc $28
345 sta $28
346 sta $4b
347 lda $29
348 adc #0
349 set2a sta $29
350 sta $4c
351 set3 txa
352 sta $26
353 sty $27
354 clc
355 bit numfl;numer.array
356 bvs w1;nein
357 jsr zahl;ja
358 bcs set
359 ;---------------------------------------
360 work clc;sortieren bis zum
361 lda $71;ersten tausch
362 ldy $72;b-element($71/$72)
363 w1 sta $22;wird zu a-element
364 adc $69;+schrittweite
365 tax;= b-element
366 tya
367 adc $6a
368 cmp $fe;test,ob b-element
369 bcc next;>arrayende,
370 bne set;wenn ja,dann
371 cpx $fd
372 bcs set;naechstes teilfeld
373 next sta $25
374 sty $23
375 stx $24
376 sta $72
377 stx $71
378 ldy $14
379 beq vergl
380 lda $4b
381 sta $61
382 adc $6b
383 sta $63
384 sta $4b
385 lda $4c
386 sta $62
387 adc $6c
388 sta $64
389 sta $4c
390 ;---------------------------------------
391 ldy #0
392 vergl lda ($24),y;deskriptor
393 b0 beq work;b-element nach
394 sta $5e;$5e-$60;wenn
395 iny;laenge=0,dann
396 lda ($24),y;naechstes element
397 sta $5f
398 iny
399 lda ($24),y
400 sta $60
401 ;--- einsprung einsortieren (ldy #2) ---
402 vers lda ($22),y;deskriptor
403 sta $5d;a-element nach
404 dey;$5b-$5d;wenn
405 lda ($22),y;laenge=0,dann
406 sta $5c;tauschen
407 dey;y-reg. = 0
408 lda ($22),y
409 sta $5b
410 beq swap
411 cmp $5e;vergleichslaenge
412 beq ver1;nach x-reg.
413 bcc ver1;holen
414 lda $5e
415 ver1 tax
416 ;---------------------------------------
417 loop lda ($5c),y;stringvergleich
418 cmp ($5f),y;fuer 1.dimension
419 b1 bcc work+1
420 bne swap
421 iny
422 dex
423 bne loop
424 ldy $5b
425 cpy $5e
426 bcc work+1;wenn gleich,dann
427 bne swap
428 ldx flag1;test auf 2.dim.
429 beq b0;nein,nach "work"
430 ;---------------------------------------
431 stx $2a;deskriptoren der
432 jsr d2set;2.dimension
433 zl dec $2a;setzen und
434 b2 beq b0;vergleich nach
435 jsr dset;den elementen
436 ldy #2;routine ist
437 z1 lda ($47),y;selbstmodi-
438 sta v1,y;fizierend
439 lda ($49),y
440 sta v2,y
441 dey
442 bne z1
443 lda ($49),y
444 b4 beq b0
445 sta $46
446 lda ($47),y
447 beq swap
448 sta $45
449 cmp $46
450 bcc v0
451 lda $46
452 v0 tax
453 v1 lda $4711,y;dummy-wert
454 v2 cmp $0815,y;    "
455 bcc b1
456 bne swap
457 iny
458 dex
459 bne v1
460 ldy $45
461 cpy $46
462 bcc b1
463 beq zl
464 ;[171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171]
465 swap ldy flag1;test 2[171][134]ensi[145]al
466 beq swap1;nein
467 jsr swapd2;ja,tauschen
468 swap1 ldy $14;test nebenarray
469 beq swap3;nein
470 dey;ja,tauschen
471 swap2 lda ($61),y
472 tax
473 lda ($63),y
474 sta ($61),y
475 txa
476 sta ($63),y
477 dey
478 bpl swap2
479 iny;y[171]reg.[178]0
480 sec
481 lda $61;nebenarray
482 sta $63;zur eins[176][171]
483 sbc $6b;tie[138]g
484 sta $61;v[176]bereiten
485 lda $62;siehe prg.[171]
486 sta $64;teil s[176]t
487 sbc $6c
488 sta $62
489 swap3 lda $5b;hauptarray
490 sta ($24),y;deskrip[164]ren
491 lda $5e;tauschen
492 sta ($22),y;
493 iny
494 lda $5c
495 sta ($24),y
496 lda $5f
497 sta ($22),y
498 iny;y[171]reg.[178]2
499 lda $5d
500 sta ($24),y
501 lda $60
502 sta ($22),y
503 ;[171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171]
504 s[176]t lda $22;nach links eins[176][171]
505 ldx $23;tieren,bis kein
506 cpx $27;tausch erfolgt bzw
507 bne so1;die linke teilfeld
508 cmp $26;grenze erreicht
509 beq b4;ist.deskrip[164]r des
510 so1 sta $24;einzus[176]tier[128]en
511 stx $25;elements bleibt in
512 sbc $69;$5e[171]$60.b[171]element
513 sta $22;wird durch zeiger
514 txa;$24[173]$25 gesetzt.
515 sbc $6a;zeiger $71[173]$72
516 sta $23;wird nicht
517 jmp vers;gea[128]ert !
518 ;
519 ;[171][171][171][171][171][171][171][171][171][171][171][171] unterprogramme [171][171][171][171][171][171][171][171][171][171][171]
520 ;
521 array lda #0;[150]aultwert fuer
522 sta flag;ganzes array
523 sta flag1;[150]ault 1.[134].
524 jsr chr[203]t;[136]ztes zeichen
525 cmp #"#";nur teilarray
526 bne arr1;nein
527 jsr $b79b;1 oder 2 [134].
528 dex
529 stx flag1;flagge 1[173]2 [134].
530 dec flag;flagge teils[176]t.
531 arr1 jsr komma
532 arr2 jsr term;nicht $b08b !!!!
533 ldy flag
534 bne teil1
535 ;[171][171][171][171][171][171][171][171] ganzes array s[176]tieren [171][171][171][171][171][171][171]
536 arr3 lda $2f;ab anfang der
537 ldx $30;arrays mit der
538 ganz sta $57;suche beginnen
539 stx $58
540 cmp $31;wenn [128]e der
541 bne ganz0;arrays erreicht,
542 cpx $32;dann nicht
543 beq fehler;gefunden,fehler !
544 ganz0 ldy #0
545 lda ($57),y
546 iny
547 cmp $45;variab[195]name
548 bne ganz1
549 lda ($57),y
550 cmp $46
551 ganz1 php;wenn gefunden,dann
552 iny;zeroflag gesetzt
553 lda ($57),y;[128]e nach $59[173]$5a
554 clc
555 adc $57
556 sta $59
557 iny
558 lda ($57),y
559 adc $58
560 sta $5a
561 tax
562 lda $59
563 plp;test,ob gefunden
564 bne ganz;naechstes array
565 iny;[171][171]array gefunden
566 lda ($57),y;test,ob array
567 cmp #1;ein[134]ensi[145]al
568 beq ganz4;ja,dann ok
569 cmp #2
570 bne fehler
571 lda flag1
572 beq ganz3
573 fehler ldx #$19;[129]mula [164]o
574 jmp ($300);komplex ausgeben
575 ganz3 iny
576 lda ($57),y
577 bne fehler
578 iny
579 lda ($57),y
580 sta flag1
581 lda #9;9
582 .byte $2c;bzw
583 ganz4 lda #7;7 byte zu
584 clc;anfang addieren
585 adc $57;um auf 1.deskr.
586 sta $57;zu zeigen
587 bcc name
588 inc $58
589 ;
590 name ldx #5;spez.platzbedarf
591 lda $46;aus variab[195]name
592 bpl name1;berechnen und ins
593 dex;x[171]register
594 dex;[181]eger [178] 2
595 name1 lda $45;string [178] 3
596 bpl name2;real  [178] 5
597 dex
598 name2 rts
599 ;[171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171]
600 ;[171][171] bereich fuer teils[176]tie[138]g ho[195] [171][171]
601 ;
602 teil1 ldy #3
603 teil2 lda $45,y
604 pha;name und anfang
605 dey;auf stack
606 bpl teil2
607 jsr komma;[128]e ho[195]
608 jsr term
609 jsr name;angegebenes
610 txa;element auch noch
611 clc;mits[176]tieren
612 adc $47
613 sta $59
614 ldy $48
615 bcc teil3
616 iny
617 teil3 sty $5a
618 pla;test auf
619 cmp $45;gleichen namen
620 bne fehler
621 pla
622 cmp $46
623 fehla bne fehler
624 pla;low[171]byte anfang
625 tay
626 pla ;high[171]byte anfang
627 cmp $30;test,ob im
628 bcc fehler;bereich der
629 bne teil4;arrays
630 cpy $2f
631 bcc fehler
632 teil4 sta $58
633 sty $57
634 cmp $5a;test,ob
635 bcc name2;anfang [179] [128]e
636 bne fehler
637 cpy $59
638 fehlb bcs fehler
639 rts
640 ;[171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171]
641 ltest lsr;ges.platz
642 [175] #2;hauptarray
643 php;[172]spez.platz
644 lda $22;nebenarray
645 asl;    [178]
646 tax;ges.platz
647 lda $23;nebenarray
648 rol;[172]spez.platz
649 bcs fehlb;hauptarray
650 tay;s[145]st fehler !
651 plp;[171][171][171][171][171][171][171][171][171][171][171][171][171][171]
652 bcc lt2;[181]eger
653 beq lt1;string
654 txa;real
655 asl
656 tax
657 tya
658 rol
659 tay
660 fehlc bcs fehlb
661 lt1 clc
662 txa
663 adc $22
664 tax
665 tya
666 adc $23
667 tay
668 lt2 rts
669 ;
670 test jsr ltest;einsp[138]g
671 stx $24;test auf gleiche
672 sty $25;elementzahl
673 lda $69;s."ltest"
674 sta $22
675 lda $6a
676 sta $23
677 lda $14
678 jsr ltest
679 cpy $25
680 bne fehla
681 cpx $24
682 fehld bne fehla
683 lda $fb;test ob beide
684 cmp $57;arrays gleich [191]d
685 bne ok1;[178][158]52000,a$,a$
686 lda $fc;wenn ja,fehler
687 cmp $58
688 beq fehlb
689 ok1 rts
690 ;[171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171]
691 swapd2 dey;alle elemente
692 sty $2a;der 2.[134].
693 jsr d2set;tauschen
694 d1 jsr dset
695 ldy #2
696 d2 lda ($47),y
697 tax
698 lda ($49),y
699 sta ($47),y
700 txa
701 sta ($49),y
702 d4 dey;einsp[138]g num.
703 bpl d2;nebenarray
704 dec $2a;tauschen
705 bne d1
706 rts
707 ;[171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171]
708 dset lda $47;deskrip[164]ren
709 clc;fuer elemente
710 adc ol;der 2.[134].
711 sta $47;berechnen
712 lda $48
713 adc oh
714 sta $48
715 clc
716 lda $49
717 adc ol
718 sta $49
719 lda $4a
720 adc oh
721 sta $4a
722 rts
723 ;
724 d2set ldy #3;v[176]bereitung
725 d3 lda $22,y;auf 1.element
726 sta $47,y;der 2.[134]ensi[145]
727 dey
728 bpl d3
729 rts
730 ;[171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171]
731 gplatz lda $fd;gesamtplatz[171]
732 sec;bedarf fuer
733 sbc $fb;hauptarray
734 sta $69;berechnen
735 lda $fe
736 sbc $fc
737 sta $6a
738 platz lda $59;wie oben fuer
739 sec;nebenarray
740 sbc $57
741 sta $22
742 tax
743 lda $5a
744 sbc $58
745 sta $23
746 ble rts
747 ;[171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171]
748 flag nop;flagge teilarray
749 flag1 nop;flagge 2 [134].
750 ol nop;offset auf 1.
751 oh nop;element 2.[134].
752 ;[171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171]
753 ;[171][171][171][171][171][171][171][171] numer.array s[176]tieren [171][171][171][171][171][171][171][171]
754 ;[171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171]
755 bl lda $71;vergl routinen
756 ldy $72;"work" bis "sort"
757 clc
758 zahl sta $5b;a[171]element
759 sty $5c
760 adc $69
761 tax
762 tya
763 adc $6a
764 cmp $fe
765 bcc bl1
766 bne ble
767 cpx $fd
768 bcs ble
769 bl1 tay
770 sta $72;b[171]element
771 stx $71;grosse schle[139]e
772 sta $5e;b[171]element
773 stx $5d;eins[176]tieren
774 lda $14
775 beq zver
776 lda $4b
777 sta $47
778 adc $6b
779 sta $4b
780 sta $49
781 lda $4c
782 sta $48
783 adc $6c
784 sta $4c
785 sta $4a
786 ;
787 zver txa
788 bit [138]d;wenn [138]d[178]$ff
789 bvs [181];dann [181]eger !
790 jsr $bba2;b[171]elem.in fac
791 lda $5b;vergl.mit
792 ldy $5c;a[171]element
793 zv1 jsr $bc5b
794 tax
795 beq bl
796 cmp flag2
797 zvb1 beq bl
798 ztau ldy type
799 dey
800 sz1 lda ($5b),y
801 tax
802 lda ($5d),y
803 sta ($5b),y
804 txa
805 sta ($5d),y
806 dey
807 bpl sz1
808 ldy $14
809 beq zv2
810 inc $2a
811 jsr d4
812 ;[171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171][171]
813 zv2 lda $5b;entspr."sort"
814 ldy $5c;b[171]element bleibt
815 cpy $27;im fac
816 bne zv3
817 cmp $26
818 beq bl
819 zv3 sta $5d
820 sty $5e
821 sbc $69
822 tax
823 tya
824 sbc $6a
825 tay
826 zv3a stx $5b
827 sty $5c
828 lda $14
829 beq zv4
830 lda $47
831 sec
832 sta $49
833 sbc $6b
834 sta $47
835 lda $48
836 sta $4a
837 sbc $6c
838 sta $48
839 zv4 txa
840 bit [138]d
841 bvc zv1
842 ;
843 [181] ldx flag2
844 ldy #0
845 i1 lda ($5b),y;vergleich
846 cmp ($5d),y;[181]eger
847 bcc kl;kleiner
848 bne gr;groesser
849 iny
850 cpy #2
851 bne i1
852 beq zvb1
853 gr txa;ergebnis
854 e[176] #$ff;herumdrehen
855 tax;wieder nach x[171]reg.
856 kl txa
857 bmi ztau
858 jmp bl
859 ;
860 flag2 .byte 1; 1 [178]kleinstes
861 ;                     255[178]groesstes
862 ;                     element an
863 ;                     arrayanfang