English version of this page
über mich
Startseite
LinksProgrammieren
- CodeOptimierung
- CodeConventionen
- GFA-Basic
Atari
Hardware-
Basteleien
Witze
Zitate
Sprüche
Braille
Kunst
Buch-Tip
historisches
Impressum
(generated: 16.05.2008)
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 :
169 :
170 :
171 :
172 :
173 :
174 :
175 :
176 :
177 :
178 :
179 :
180 :
181 :
182 :
183 :
184 :
185 :
186 :
187 :
188 :
189 :
190 :
191 :
192 :
193 :
194 :
195 :
196 :
197 :
198 :
199 :
200 :
201 :
202 :
203 :
204 :
205 :
206 :
207 :
208 :
209 :
210 :
211 :
212 :
213 :
214 :
215 :
216 :
217 :
218 :
219 :
220 :
221 :
222 :
223 :
224 :
225 :
226 :
227 :
228 :
229 :
230 :
231 :
232 :
233 :
234 :
235 :
236 :
237 :
238 :
239 :
240 :
241 :
242 :
243 :
244 :
245 :
246 :
247 :
248 :
249 :
250 :
251 :
252 :
253 :
254 :
255 :
256 :
257 :
258 :
259 :
260 :
261 :
262 :
263 :
264 :
265 :
266 :
267 :
268 :
269 :
270 :
271 :
272 :
273 :
274 :
275 :
276 :
277 :
278 :
279 :
280 :
281 :
282 :
283 :
284 :
285 :
286 :
287 :
288 :
289 :
290 :
291 :
292 :
293 :
294 :
295 :
296 :
297 :
298 :
299 :
300 :
301 :
302 :
303 :
304 :
305 :
306 :
307 :
308 :
309 :
310 :
311 :
312 :
313 :
314 :
315 :
316 :
317 :
318 :
319 :
320 :
321 :
322 :
323 :
324 :
325 :
326 :
327 :
328 :
329 :
330 :
331 :
332 :
333 :
334 :
335 :
336 :
337 :
338 :
339 :
340 :
341 :
342 :
343 :
344 :
345 :
346 :
347 :
348 :
349 :
350 :
351 :
352 :
353 :
354 :
355 :
356 :
357 :
358 :
359 :
360 :
361 :
362 :
363 :
364 :
365 :
366 :
367 :
368 :
369 :
370 :
371 :
372 :
373 :
374 :
375 :
376 :
377 :
378 :
379 :
380 :
381 :
382 :
383 :
384 :
385 :
386 :
387 :
388 :
389 :
390 :
391 :
392 :
393 :
394 :
395 :
396 :
397 :
398 :
399 :
400 :
401 :
402 :
403 :
404 :
405 :
406 :
407 :
408 :
409 :
410 :
411 :
412 :
413 :
414 :
415 :
416 :
417 :
418 :
419 :
420 :
421 :
422 :
423 :
424 :
425 :
426 :
427 :
428 :
429 :
430 :
431 :
432 :
433 :
434 :
435 :
436 :
437 :
438 :
439 :
440 :
441 :
442 :
443 :
444 :
445 :
446 :
447 :
448 :
449 :
450 :
451 :
452 :
453 :
454 :
455 :
456 :
457 :
458 :
459 :
460 :
461 :
462 :
463 :
464 :
465 :
466 :
467 :
468 :
469 :
470 :
471 :
472 :
473 :
474 :
475 :
476 :
477 :
478 :
479 :
480 :
481 :
482 :
483 :
484 :
485 :
486 :
487 :
488 :
489 :
490 :
491 :
492 :
493 :
494 :
495 :
496 :
497 :
498 :
499 :
500 :
501 :
502 :
503 :
504 :
505 :
506 :
507 :
508 :
509 :
510 :
511 :
512 :
513 :
514 :
515 :
516 :
517 :
518 :
519 :
520 :
521 :
522 :
523 :
524 :
525 :
526 :
527 :
528 :
529 :
530 :
531 :
532 :
533 :
534 :
535 :
536 :
537 :
538 :
539 :
540 :
541 :
542 :
543 :
544 :
545 :
546 :
547 :
548 :
549 :
550 :
551 :
552 :
553 :
554 :
555 :
556 :
557 :
558 :
559 :
560 :
561 :
562 :
563 :
564 :
565 :
566 :
567 :
568 :
569 :
570 :
571 :
572 :
573 :
574 :
575 :
576 :
577 :
578 :
579 :
580 :
581 :
582 :
583 :
584 :
585 :
586 :
587 :
588 :
589 :
590 :
591 :
592 :
593 :
594 :
595 :
596 :
597 :
598 :
599 :
600 :
601 :
602 :
603 :
604 :
605 :
606 :
607 :
608 :
609 :
610 :
611 :
612 :
613 :
614 :
615 :
616 :
617 :
618 :
619 :
620 :
621 :
622 :
623 :
624 :
625 :
626 :
627 :
628 :
629 :
630 :
631 :
632 :
633 :
634 :
635 :
636 :
637 :
638 :
639 :
640 :
641 :
642 :
643 :
644 :
645 :
646 :
647 :
648 :
649 :
650 :
651 :
652 :
653 :
654 :
655 :
656 :
657 :
658 :
659 :
660 :
661 :
662 :
663 :
664 :
665 :
666 :
667 :
668 :
669 :
670 :
671 :
672 :
673 :
674 :
675 :
676 :
677 :
678 :
679 :
680 :
681 :
682 :
683 :
684 :
685 :
686 :
687 :
688 :
689 :
690 :
691 :
692 :
693 :
694 :
695 :
696 :
697 :
698 :
699 :
700 :
701 :
702 :
703 :
704 :
705 :
706 :
707 :
708 :
709 :
710 :
711 :
712 :
713 :
714 :
715 :
716 :
717 :
718 :
719 :
720 :
721 :
722 :
723 :
724 :
725 :
726 :
727 :
728 :
729 :
730 :
731 :
732 :
733 :
734 :
735 :
736 :
737 :
738 :
739 :
740 :
741 :
742 :
743 :
744 :
745 :
746 :
747 :
748 :
749 :
750 :
751 :
752 :
753 :
754 :
755 :
756 :
757 :
758 :
759 :
760 :
761 :
762 :
763 :
764 :
765 :
766 :
767 :
768 :
769 :
770 :
771 :
772 :
773 :
774 :
775 :
776 :
777 :
778 :
779 :
780 :
781 :
782 :
783 :
784 :
785 :
786 :
787 :
788 :
789 :
790 :
791 :
792 :
793 :
794 :
795 :
796 :
797 :
798 :
799 :
800 :
801 :
802 :
803 :
804 :
805 :
806 :
807 :
808 :
809 :
810 :
811 :
812 :
813 :
814 :
815 :
816 :
817 :
818 :
819 :
820 :
821 :
822 :
823 :
824 :
825 :
826 :
827 :
828 :
829 :
830 :
831 :
832 :
833 :
834 :
835 :
836 :
837 :
838 :
839 :
840 :
841 :
842 :
843 :
844 :
845 :
846 :
847 :
848 :
849 :
850 :
851 :
852 :
853 :
854 :
855 :
856 :
857 :
858 :
859 :
860 :
861 :
862 :
863 :
864 :
865 :
866 :
867 :
868 :
869 :
870 :
871 :
872 :
873 :
874 :
875 :
876 :
877 :
878 :
879 :
880 :
881 :
882 :
883 :
884 :
885 :
886 :
887 :
888 :
889 :
890 :
891 :
892 :
893 :
894 :
895 :
896 :
897 :
898 :
899 :
900 :
901 :
902 :
903 :
904 :
905 :
906 :
907 :
908 :
909 :
910 :
911 :
912 :
913 :
914 :
915 :
916 :
917 :
918 :
919 :
920 :
921 :
922 :
923 :
924 :
925 :
926 :
927 :
928 :
929 :
930 :
931 :
932 :
933 :
934 :
935 :
936 :
937 :
938 :
939 :
940 :
941 :
942 :
943 :
944 :
945 :
946 :
947 :
948 :
949 :
950 :
951 :
952 :
953 :
954 :
955 :
956 :
957 :
958 :
959 :
960 :
961 :
962 :
963 :
964 :
965 :
966 :
967 :
968 :
969 :
970 :
971 :
972 :
973 :
974 :
975 :
976 :
977 :
978 :
979 :
980 :
981 :
982 :
983 :
984 :
985 :
986 :
987 :
988 :
989 :
990 :
991 :
992 :
993 :
994 :
995 :
996 :
997 :
998 :
999 :
1000 :
1001 :
1002 :
1003 :
1004 :
1005 :
1006 :
1007 :
1008 :
1009 :
1010 :
1011 :
1012 :
1013 :
1014 :
1015 :
1016 :
1017 :
1018 :
1019 :
1020 :
1021 :
1022 :
1023 :
1024 :
1025 :
1026 :
1027 :
1028 :
1029 :
1030 :
1031 :
1032 :
1033 :
1034 :
1035 :
1036 :
1037 :
1038 :
1039 :
1040 :
1041 :
1042 :
1043 :
1044 :
1045 :
1046 :
1047 :
1048 :
1049 :
1050 :
1051 :
1052 :
1053 :
1054 :
1055 :
1056 :
1057 :
1058 :
1059 :
1060 :
1061 :
1062 :
1063 :
1064 :
1065 :
1066 :
1067 :
1068 :
1069 :
1070 :
1071 :
1072 :
1073 :
1074 :
1075 :
1076 :
1077 :
1078 :
1079 :
1080 :
1081 :
1082 :
1083 :
1084 :
1085 :
1086 :
1087 :
1088 :
1089 :
1090 :
1091 :
1092 :
1093 :
1094 :
1095 :
1096 :
1097 :
1098 :
1099 :
1100 :
1101 :
1102 :
1103 :
1104 :
1105 :
1106 :
1107 :
1108 :
1109 :
1110 :
1111 :
1112 :
1113 :
1114 :
1115 :
1116 :
1117 :
1118 :
1119 :
|
' ############################################################################# ' ############################################################################# ' ' Deutsch: ' ========= ' Dieser Quellcode ist von Folke Rinneberg ' Webseite: http://www.Rinneberg.de/programming/gfa.htm ' E-Mail: Folke_R@gmx.de ' ' Du kannst diesen Quellcode frei nutzen, Veraendern und Erweitern. ' Es waehre nett, wenn du mir mitteilen wuerdest, wenn du diesen Quellcode ' benutzt/veraenderst oder erweiterst. Verbesserungen/Erweiterung wuerde ' ich vielleicht gerne uebernehmen, Nutzung wuerde ich vielleicht gerne an ' dieser Stelle verlinken. ' ' Die Softwarequalitaet ist vermutlich nicht besonders hoch, da ich noch ' jung und unerfahren war, als ich ihn schrieb. Eine UEberarbeitung ist ' nicht geplant. ' ' ' English: ' ========= ' This source code was written by Folke Rinneberg ' Web Site: http://www.Rinneberg.de/programming/gfa.htm#english ' e-mail: Folke_R@gmx.de ' ' You are free to use, modify and extend this source code. ' It would be nice, if you contact me (e.g. by e-mail) when you ' use/modify or extend this source code. Perhaps I would ' put Improvements or extensions to this web site. ' Usage of this source code may be linked here. ' ' The quality of this source code may be quite low, because I was young and ' had few experiences with programming when I wrote this source code. ' I have no plans to improve this source code by myself. ' ' ############################################################################# ' ############################################################################# ' ' ' ' 19.06.1999 Speicherverbrauch 41088 Byte (VERSION 074) ' last modified: 22.07.2001 (dokumentation erweitert) ' ' Bekannte Fehler: ' Der Encoder verliert bei groesseren Bildern manchmal ein Pixel ' (vermutlich, wenn die Tabelle geleehrt wird) ' ' Funktionsumfang: ' 1.codiert GIF87- Dateien (nur Monochrome Quelle und Ziel ' 2.decodiert GIF87- Dateien (nur Monochrome Quelle) ' 3.kein interlace ' ' Testaufrufe in der Procedure main ' ' WAS BEIM STARTEN PASSERT: (nur im 640*400 Pixel Modus Monochrom sinnvoll) ' 1. EINE FILESELECT-BOX ERSCHEINT. man soll ein Bild (32000 Bytes) ' serlektieren, welches dann in den Bildschirmspeicher geladen wird ' 2. MAN SELEKTIERT EINEN BEREICH MI DER MAUS. ' - EINMAL KLICKEN F"+Chr$(154)+"R DEIE ECKE LINKS OBEN ' - DANN EINEMAL F"+Chr$(154)+"R DIE GEGEN"+Chr$(154)+"BERLIEGENDE ECKE ' 3. NUN WIRD DER AUSGEW"+Chr$(142)+"HLTE BEREICH CODIERT ' 4. ES WIRD VERSIUCHT DAS ERGEBNIS AUF A: ZU SPEICHERN ' 5. ENDE ' ' ANDERE TESTS WERDEN IN DER PROCEDURE MAIN MOMENTAN "+Chr$(154)+"BERSPRUNGEN ODER ' SIND AUSKOMMENTIERT ' ' Cls ' Testen: ' - ? funktioniert analyse noch???? (nein mu"+Chr$(158)+" angepasst werden) ' ' ' VORGENOMMENE OPTIMIERUNGEN: ' Copiler-Optionen hatten keine geschwindigkeitsauswirkungen!!! ' "PINGU.GIF" ' optimierung: mod 8 -> and 7 (+86%)(ab V 2_059)(+45% decoden +34% encoden) ' div 8 -> shr( ,3) (+20%)(ab V 2_060)(+0.5%decoden +0.3%encoden) ' 7-x -> 7 Xor x (+16%)(ab V 2_061)(0.47%decoden +0.4%encoden) ' - einsetzen von searchcode() (ab v 2_062)( +25% encoden) ' - Putcodepixel() durch nichtrekursive ersetzt ' (ab v 2_064)(+37.2%decoden) ' - einsetzen von getpixel() (ab v 2_065)( +35% encoden) ' ' Kurzziele: ' - encode in Datei (nur 256Byte+16bit zielspeicher)dann ganzen Rastadatablock schreiben ' - decode direkt aus Datei ' - Ablegerprogramm, welches GIFs von Kommentaren befreit ' - interlaced unterst"+Chr$(129)+"tzen ' Defwrd "a-z" !! Defaultvareablentyp nun word (16Bit Integer) Deflist 3 !! Anzeige Modum im Interpreter auf Typ 3 setzen ' @Dims @Init @Main Procedure Dokumentation !Nur Text (wird nie aufgerufen !) ' Gif En-/De- coder ' 17.02.1999 (Projektstart) ' Letzte "+Chr$(142)+"nderung: 12.03.1999 ' ' Version 011:(19.02.1999) ' - testdekomopression3 arbeitet scheinbar korrekt ' (bisher wird nicht gepr"+Chr$(129)+"ft, ob man aus dem codestream rausl"+Chr$(132)+"uft ' (wie bei den kommerziellen auch nicht (PSP und arachne st"+Chr$(129)+"rzen ab!!))) ' Version 017 (19.02.1999) ' - encode funktioniert fast (ab und zu wird ein Pixel zuviel Codiert!) ' (trotz vieler Variationen nicht korrigiert worden) ' Version 020 (20.02.1999) ' - encode kodiert jetzt die richtige Anzahl von Pixeln ' ? erreichen der 12 Bit-Grenze noch ungetestet!!! ' Version 032 (21.02.1999) ' - decode2 ist Bitbasiert ' allerdings wird trotz k und ppp korrekt ' die neue Pixelkette nicht korrekt zusammengesetzt ????? WARUM ' Version 34 (24.02.1999) ' - anfang einer bitbasiertenn version mit doppeltverkettetem Baum ' Ansatz aus Version 32 verworfen, wegen der oben beschriebenen Probleme ' und dem sehr viel h"+Chr$(148)+"herem speicherbedarf ' Version 2_036 (24.02.1999) Ab hier nur noch die Bitversion in der Quelle ' + decode funktioniert (mit dopeltverl. Baum) ' - f"+Chr$(129)+"r kleine quellen ' * gro"+Chr$(158)+"e quellen analysieren / decodieren ' Version 2_041 (27.02.1999) ' + decoder funktioniert auch mit mehereren RastaDataBlocks ' Version 2_049 (04.03.1999) ' + encode funktioniert nun auch auf bit ebene ' - bisher nur f"+Chr$(129)+"r einen RastaDataBlock ' Version 2_053 (05.03.1999) ' + encode funktioniert mit mehreren RastaDataBlocks ' Version 2_056 (05.03.1999) ' + encode funktioniert auch mit <CC> (wenn CodeTable voll werden sollte) ' Version 2_058 (05.03.1999) ' PINGU.GIF decode:64,753s encode:82,69s ' Version 2_061 (06.03.1999) ' + en-/decoder jetzt doppelt so schnell (durch obrige Optimieriungen) ' PINGU.GIF decode:41,675s encode:62,925s ' Version 2_062 (06.03.1999) ' + FirstPixel() von rekursiv -> Schleife (beschl"+Chr$(132)+"unigung fast auf 1/3) ' + @serchcode() direkt bei dem Aufruf eingesetzt (->encode 25% schneller ) ' PINGU.GIF decode:29.91 s encode:40.52 s ' Version 2_064 (07.03.1999) ' + nichtrekursives PutcodePixel() -> schnelleres decoden ' PINGU.GIF decode:18.77 s encode:40.59 s ' - kosten dieser Ma"+Chr$(158)+"nahme: Ein Array mit 80192Bytes gr"+Chr$(148)+""+Chr$(158)+"e (lange&(4096)) ' Version 2_065 (07.03.1999) ' + @getpixel() direkt bei Aufruf eingesetzt (->encode 35% schneller) ' PINGU.GIF decode:18.77 s encode:14.215s ' Version 3_073 (12.03.1999) ' + decode jetz dierekt mit ausgabe und direkt aus der Quelle (Mehrere RDBlocks) ' Pingu.GIF decode:18.71 s (nicht gleich dem fr"+Chr$(129)+"geren decode) ' Version 3_074 (13.03.1999) ' + decode ber"+Chr$(129)+"cksichtigt jetzt die Farbeintr"+Chr$(132)+"ge im ColorTable ' ! decode in Put-String getestet (funktioniert) ' !!!!!!!!!!!!! kein klipping!!!!! ' ' Weitere Ziele: ' ************** ' ' - encode/decode auch f"+Chr$(129)+"r INTERLACE ' ' - Fehlerabfragen (sinnvolle) aufnehmen ! ' - (out of codestream) = codestram zu ende ohne da"+Chr$(158)+" einen endecode ' - (codemap overflow) = Codelen steigt "+Chr$(129)+"ber 12Bit (<CC> fehlt im codestream) ' ' - Animierte GIFs ' ' Austesten: ' ********** ' - Expansionblocks: (ermitteln) (f"+Chr$(129)+"r animated gifs) ' ' Die werte sind aus einem Animierten GIF ausgelesen ! GIF89a ' ------------------------------------------------------ ' - Loop 1 ' 232 \ 3*256+232 = 1000 Wiederholungen ' 3 / ' 0 ' ' - delay ! ' 249 ' 0 !Eigentlich m"+Chr$(129)+"sste hier die L"+Chr$(132)+"nge des Blocks stehen ' 100 \ 0*256+100 = 100 (100/100 Secunden) ' 0 / ' 0 ' ' - mehrere Gifs in einer Datei ' ' Testen ' ((bei mehreren Gift mit alter Codetabelle arbeiten (<CC>am Anfang nicht))) ' ((?? wird das von Netscape etc logisch korrekt interpretiert???)) ' ' Fernziele: ' ********** ' - encoden mit einer art GETGIF(x,y,x2,y2,a$) ' ' - decodieren direkt aus einer Datei LOADGET("a:\test.gif",s%,beitbreit) ' - encoden direkt in eine Datei ' ' - auch FarbGIFs ' - codierung bei ENCODE() optimieren (nicht nur "greedy") ' - daf"+Chr$(129)+"r testen, ob wirklich codes dann mehrfach in der code tabelle ' Return Procedure Optimierungsideen !Nur Text (wird nie aufgerufen !) ' - nicht immer maximallangen Code verwenden (abweichend von "greedy") ' Problem: Wie vorgehen? ' L"+Chr$(148)+"sungen: - 1.Breitensuche (so da"+Chr$(158)+" alle codierungen etwa gleichwerit ' in der Quelle) ' 2.Wenn gleich weit und gleiche Codetabelle ' nur den besseren weiter verfolgen (warsch. nur sehr selten) ' 3.? Nur z.B.20 besten weiterverfolgen ' ?(comprimiertebits/l"+Chr$(132)+"ngedescomprimierten)? ' 4.? erst vergleichen, wenn alle codes verbraten ? ' (sehr "breit" suche) ' ' ' - vergleich der l"+Chr$(132)+"nge von Interlace/ NonInterlace ' -?einsetzen von <cc> an geeigneter Stelle ' -?<cc> verhindern, wenn Bild schon fast zu ende ' (lieber alte codetabell weiterverwenden (dann darf nat"+Chr$(129)+"rlich kein neuer ' Code entstehen (4096) sind obere grenze ' -?GIF in teilGIFs Zerlegen (wei"+Chr$(158)+"fl"+Chr$(132)+"chen dann nicht mitcodieren) ' verwenden des LEFT und TOP Erstes um die Teilbilder zu plazieren ' Alle Teilbilder in eine Quelle ' ' Animierte Gifs ' **************** ' - Nur ver"+Chr$(132)+"nderte Teile in Folgebildern speichern ' (mit LEFT / TOP positioniert) Return ' Procedure Dims Dim Hochbasis2%(14) !Werte 2^0 bis 2^13 (F"+Chr$(129)+"r getcode_neu an V3_67) ' --------------------------------------------- ' (noch nicht genutzt !!!!) ' Bin"+Chr$(132)+"r 2.Version (rekursiv (ab V034) ' ersetzt code$() und codelang() Dim Pref&(4096) ! nummer des prfixcodes ' next ist nur zur wesentlich schnelleren suche, da immer codes gesucht werden ' ,deren Prefix bereits gefunden wurde (aus Last& und K! kann sofort gepr"+Chr$(129)+"ft ' werden, ob der l"+Chr$(132)+"ngere code existiert) Dim Next&(2,4096) ! f"+Chr$(129)+"r den doppeltverkettenen Baum ! f"+Chr$(129)+"r schnelleres finden Adr%=0 ! zwischnlager f"+Chr$(129)+"r adressen (global damit bei rekursionen nicht immer neu angelegt) ' --------------------------------------------- Dim Lange&(4096) !l"+Chr$(132)+"nge des Codes in der Codetabelle ! optimierung V2_064 ' dadurch ein nichtrekursives putcodepixel() m"+Chr$(148)+"glich Return Procedure Init Local I& For I&=0 To 13 Hochbasis2%(I&)=2^I& !Werte 2^0 bis 2^13 (F"+Chr$(129)+"r getcode_neu an V3_67) Next I& ' ' weitere Parameter f"+Chr$(129)+"r encode Screenwidth&=16 !Anzeigefl"+Chr$(132)+"chen-Abmessungen Screenheight&=16 ! Global!=True !Verwenden der globalen Farbpalette ' (bei s/w bildern immer sinnvoll (wie k"+Chr$(148)+"nnte sicgh eine ' lokale schon von der globalen unterscheiden? ' (gr"+Chr$(129)+"n/gelb statt s/w ??))) Cr&=0 !0+1 Bits (Farbaufl"+Chr$(148)+"sung) ????Was bedeutet da"+Chr$(158)+" ???? (nicht ganz klar) Pixel&=0 !0+1 Bits pro pixel Farbtiefe Backgroundcolor&=0 !Hintergrundfarbe(???wof"+Chr$(129)+"r???) Xoff&=0 !verschiebung des Bildes vom Nullpunkt Yoff&=0 !verschiebung des Bildes vom Nullpunkt Intelace!=False !Interlace aufbau oder sequential order ' globale vareablen: en/de code ' Rastadatablocklang% ! x Hierhin kommt die L"+Chr$(132)+"nge des momentarnen RastaDataBlocks (adresse) ' Codelen& ! x x Codierungsl"+Chr$(132)+"nge (am anfang 3) ' ? Rastablocklang& ! x nach sovielen Byrtes beginnt eventuell ein neuer RastaData ' ? Farbe1 ! x gibt an welche der beiden Farben schwarz ist ' Return PROCEDURE Main ' Ziel$=String$(30000,Chr$(0)) Quell$=String$(30000,Chr$(0)) !! Speicherplatz f"+Chr$(129)+"r das Quellgif(willk"+Chr$(129)+"rliche gr"+Chr$(148)+""+Chr$(158)+"e) ' ' Alert 2,"|Was willst du?|GIF ",1,"ANZEIGEN|ERZEUGEN",Erg& If Erg&=2 Print "GIF von einem Bildschirmausschnitt erzeugen" Goto Getten !Bildausschnitt vom Bildschirm ausw"+Chr$(132)+"hlen und auf ' a: als GIF speichern (dauert eine Weile) Else if Erg&=1 Print "W"+Chr$(132)+"hle das anzuzeigende GIF aus" Fileselect "d:\entwickl.ung\gif\*.gif","pingu.gif",Wahl$ If Wahl$<>"" Z%=V:Quell$ Bload Wahl$,Z% @Makex_y(0,0,Z%,Xbios(2),80) !Gif ausgeben Ecke oben links ~Inp(2) Endif Endif End ' ' Goto Ohne_erstdecodieren ' ' Analyse(Fehlersuche&) ! funktioniert in dieser Version nichtmehr !!! ' ' ' ' Zu Demonstrationszwecken: ' ------------------------------- ' ! decodieren eines Gifs in einen Putstring (P$) Get 0,0,271,319,P$ Do Fileselect "d:\entwickl.ung\gif\*.gif","pingu.gif",Wahl$ Exit if Wahl$="" Bload Wahl$,V:Quell$ Line 16,0,16,100 ' @Makex_y(17,11,V:Quell$,Xbios(2),80) ! TEST ' @Makex_y(0,0,V:Quell$,V:P$+6,34) !!Gif ausgebn (in einen Put-String) (Parameter siehe Proc.) ' ' !! mehrfache Ausgabe des Putstrings, in den das GIF decodiert wurde For I&=0 To 80 Put I&*3,I&,P$ Pause 5 Next I& ~Inp(2) Loop End ' ' ' ' @Analyse(V:Quell$,V:Ziel$) ! funktionert in dierer Version nicht! Print "*******************" ~Inp(2) ' Goto Ohne_piclesen ' Ohne_erstdecodieren: ' Getten: !!!!!!!!!!!!!!!!!!!!! ' ' BILD (32000 BYTE FORMAT) LADEN Fileselect "d:\*.pic","*.*",Wahl$ Bload Wahl$,Xbios(2) Ohne_piclesen: ' ' Bmove Xbios(2)+16000,V:Quell$,1000 ! Zu testzwecken ' ' Encode(V:Quell$,16,16,V:Ziel$,V:Lang&) !auf String-Basis ' Print At(1,1); ' @Analyse(V:Ziel$) ' ' Print Ziel$ Q2$=String$(30000,Chr$(0)) !erstmal hierhin comprimieren!! Z%=V:Q2$ T%=Timer ' Print "Encoding beginnt!" ' Print "-----------------" ' ' ' Selektion des Bildes mit der Maus Boundary 0 Deffill 1,1,1 Graphmode 3 Aktiv!=False Raus!=False While Mousek<>0 Wend Defmouse 5 While Raus!=False If Mousek=1 If Aktiv!=False ' Print "aktiv =false" Ox&=Mousex Oy&=Mousey Aktiv!=True Else ' Print "aktiv =true" If Ux&<>Ox& And Uy&<>Oy& Raus!=True Endif Endif Else if Mousek=2 Aktiv!=False Endif If Aktiv!=True Ux&=Mousex Uy&=Mousey Pbox Ox&,Oy&,Ux&,Uy& While Mousek<>0 Wend Pause 5 Pbox Ox&,Oy&,Ux&,Uy& Endif Wend Defmouse 0 If Ox&>Ux& Swap Ux&,Ox& Endif If Oy&>Uy& Swap Uy&,Oy& Endif Get Ox&,Oy&,Ux&,Uy&,H$ Put 0,0,H$ ' ende der selektion (Bild ist nun in der Ecke oben links) ' @Encode_bin(Xbios(2),Ux&-Ox&+1,80,Uy&-Oy&+1,Z%,Lang%) ' Parameter:(Quell%,Breit&,B_ofset&,Hoch&,Ziel%,Var Ziellen%) ' Print At(1,15) Print "Encoding beendet!" Print "-----------------" Print Lang% T%=Timer-T% Print "Zeitbedarf:";T% Div (200*3600);"h";(T% Div (200*60)) Mod 60;"m";(T% Mod (200*60))/200;"s" Print "Press any Key" ~Inp(2) Print Print "speicher auf a:" Bsave "a:\t.gif",Z%,Lang% ' ' Graphmode 3 !\ Bild teilweise unk"+Chr$(132)+"ntlich machen, damit man von der Deffill 1,2,3 ! >Makex_y() "+Chr$(129)+"berhaupt was sieht Pbox 0,0,640,400!/ @Makex_y(0,0,Z%,Xbios(2),80) !Gif ausgeben Ecke oben links End ' ' Ziel$=String$(30000,Chr$(0)) ' @Analyse(V:Q2$,V:Ziel$) ' ~Inp(2) ' Print "Analyse" Print "Putcodepixel%:";Putcodepixel%;" " ~Inp(2) ' Return ' Procedure Encode_bin(Quell%,Breit&,B_ofset&,Hoch&,Ziel%,Var Ziellen%) ' Quell% : Adresse, an der die Graphikdaten beginnen ' Breit& : Breite des Bildes (in pixeln) ' B_ofset : Byteabstanz zwischen den Zeilen ' Hoch& : H"+Chr$(148)+"he des Bildes ' Ziel% : Adresse, an die das Ergebnis geschrieben werden soll ' VORSICHT (es mu"+Chr$(158)+" genug Platz da sein) ' WORD{ziellen%}: gibt an, wie viel platz zur verf"+Chr$(129)+"gung steht (BEI AUFRUF) (wenn zu wenig, Laufzeitfehlermeldung) ' WORD{ziellen%}: gibt an, wie viel platz ben"+Chr$(148)+"tigt wurde ' ' Local Sig$,Byte5_10&,Color_map$ Local Oldziel% Oldziel%=Ziel% ' ---------------------------------------------------------------------------- Sig$="GIF87a" ! Gif_signature Bmove V:Sig$,Ziel%,6 ! Gif_signature Add Ziel%,6 ! Gif_signature ' ---------------------------------------------------------------------------- ' @Screen_descriptor Byte{Ziel%+0}=Byte{V:Breit&+1} Byte{Ziel%+1}=Byte{V:Breit&} Byte{Ziel%+2}=Byte{V:Hoch&+1} Byte{Ziel%+3}=Byte{V:Hoch&} Byte5_10&=0 !Init If Global!=True !!!! eigentlich immer der Fall Add Byte5_10&,128 Endif Add Byte5_10&,Cr&*2^4 Add Byte5_10&,Pixel& Byte{Ziel%+4}=Byte5_10& Byte{Ziel%+5}=Backgroundcolor& Byte{Ziel%+6}=0 !Terminator! Add Ziel%,7 ' ---------------------------------------------------------------------------- ' @Global_color_map Color_map$=""+Chr$(255)+""+Chr$(255)+""+Chr$(255)+""+Chr$(0)+Chr$(0)+Chr$(0) !Schwarz wei"+Chr$(158)+" Bmove V:Color_map$,Ziel%,6 Add Ziel%,6 ' ---------------------------------------------------------------------------- ' @Image_descriptor Byte{Ziel%}=Asc(",") Byte{Ziel%+1}=Byte{V:Xoff&+1} Byte{Ziel%+2}=Byte{V:Xoff&} Byte{Ziel%+3}=Byte{V:Yoff&+1} Byte{Ziel%+4}=Byte{V:Yoff&} Byte{Ziel%+5}=Byte{V:Breit&+1} Byte{Ziel%+6}=Byte{V:Breit&} Byte{Ziel%+7}=Byte{V:Hoch&+1} Byte{Ziel%+8}=Byte{V:Hoch&} ' Byte 10 | M I 0 0 0 pixel (einfach nur global genutzt) If Intelace!=True Byte{Ziel%+9}=64 Else Byte{Ziel%+9}=0 Endif Add Ziel%,10 ' ---------------------------------------------------------------------------- ' @Local_color_map !!!! Bisher werden keine lokalen Farbpaletten unterst"+Chr$(129)+"tzt (Kommentar siehe INIT) ' ---------------------------------------------------------------------------- ' @Rasta_data ' !!!! bisher interlace nicht unterst"+Chr$(129)+"tzt Byte{Ziel%}=2 !wie bits pro pixel (nur statt 1, 2) ' Rastadatablocklang%=Ziel%+1 !Hierhin kommt die L"+Chr$(132)+"nge des 1. RastaDataBlocks ' Codelen&=3 ! 2+1 bits!!! Add Ziel%,2 ' @Compress_bin(Quell%,Breit&,B_ofset&,Hoch&,Ziel%) ' ' Print "Bisherige L"+Chr$(132)+"nge des GIFs:";Ziel%-Oldziel% ' ~Inp(2) ' Setzen der L"+Chr$(132)+"nge des RastaDatablocks !!!!!!!!sollte in Putcode() ' gemachrt werden !!!!!!!!!!!! ' Byte{Ziel%}=0 !Terminator des Datensreams Inc Ziel% ' ' ---------------------------------------------------------------------------- ' @Gif_terminator Byte{Ziel%}=Asc(";") Inc Ziel% ' ---------------------------------------------------------------------------- ' bisher keine EXTENSION BLOCKS!!!! ' Ziellen%=Ziel%-Oldziel% Return Procedure Compress_bin(Quell%,Breit&,Z_off&,Hoch&,Var Ziel%) ! "+Chr$(8)+" ' Quell% : adresse, ab der die Graphikdaten gelesen werden sollen ' Breit& : Breite des zu codierenden Bildes in Pixeln ' Z_off& : Byteabstand zwischen 2 Zeilen im Quellbild ' (Beim Bildschirm MS124 80) ' Hoch& : H"+Chr$(148)+"he des zu codierenden Bildes ' Ziel% : Adresse, am die das codierte Bild zu schreiben ist ' (Adresse zeigt am Ende hinter das letzten beschriebenen Byte) ' Local Zielpos%,Quellpos% Local Last&,Zeile&,Code& ' Zeile&=0 !so viele Zeilen haben wir schon gesannt Zielpos%=0 !So viel bits kompressionsstream sind schon da! Quellpos%=0 !als n"+Chr$(132)+"chstes bit 0 lesen ' ' 1. @Codeinitbin2(Next&) !Code-Table initialisieren ' 2.5 (so "sollte" jeder GIF RasterStream beginnen) @Putcode2(4,Ziel%,Zielpos%) !<CC> Last&=4 ' Do ' 3. ' K!=@Getpixel(Breit&,Hoch&,Z_off&,Quell%,Quellpos%,Zeile&) ' ' @Getpixel()--------------------------------------------------------------- ' liefert TRUE, wenn pixel schwarz ' !!! hier sp"+Chr$(132)+"ter INTERLACE implementieren (durch ber"+Chr$(129)+"cksuichtigung von Zeile und hoch) ' If Quellpos%=Breit& !N"+Chr$(132)+"chste Zeile beginnt nun! Add Quell%,Z_off& !Quelladresse korregieren !!! hier f"+Chr$(129)+"r interlace "+Chr$(132)+"ndern Quellpos%=0 !Nun wieser am Zeilenanfang! Inc Zeile& !neue Zeile Endif K!=Btst(Byte{Quell%+Shr(Quellpos%,3)},7 Xor (Quellpos% And 7)) ! optimiert Inc Quellpos% !n"+Chr$(132)+"chstes Mal n"+Chr$(132)+"chster Pixel ' -------------------------------------------------------------------------- ' ' Code&=@Searchcode(Last&,K!) Code&=Next&(-K!,Last&) !alt&+K! in codetabelle? ! optimiert ' If -1<Code& ! ist drin Last&=Code& Else ! String ist NICHT in der CodeTabelle @Addcode(Last&,K!,Next&) @Putcode2(Last&,Ziel%,Zielpos%) Last&=-K! If Next&=2^Codelen&+1 !Codelen wird erh"+Chr$(148)+"ht !War vorher fehlerhaft Inc Codelen& Endif If Next&=4096 ! CodeTabelle hat maximale F"+Chr$(129)+"llung @Putcode2(4,Ziel%,Zielpos%) !<CC> @Codeinitbin2(Next&) ! -> CodeTabelle Leeren Last&=4 ! bisher kein vorheriger Code Endif Endif ' ' Zu Debugging zwecken ' ********************** ' Print At(60,1);"K:";-K!;" " ' Print At(60,2);"Zeile :";Zeile&;" " ' Print last :";Last&;" " ' Print ;"Zielpos :";Zielpos%;" " ' Print "Quellpos:";Quellpos%;" ";Quellpos%+Zeile&*Breit&;" " ' Print "Next :";Next&;" " ' Print "rdblocklang:";Rastadatablocklang% ' Print At(60,7);"codelen :";Codelen&;" " ' ' letzter Code If Zeile&=>Hoch&-1 !Letzte Zeile erreicht ! If Quellpos%=Breit& ! Letzten DatenCode ausgeben !!!!!Testen If -1<Code& ! war drin nun noch ausgeben @Putcode2(Last&,Ziel%,Zielpos%) Else !Den einen Pixel (da nicht drin war ist rest schon ausgegeben) @Putcode2(-K!,Ziel%,Zielpos%) Endif Exit if True Endif Endif Loop @Putcode2(5,Ziel%,Zielpos%) !<EOI> Bildende Add Ziel%,(Zielpos%+7) Div 8 !Zieladresse endg"+Chr$(129)+"tig setzen Byte{Rastadatablocklang%}=(Zielpos%+7) Div 8 !L"+Chr$(132)+"nge des letzten RastaDataBlocks schreiben Return Procedure Putcode2(Code&,Var Ziel%,Pos%) ! "+Chr$(8)+" !03.03.1999 ge"+Chr$(132)+"ndert ?"+Chr$(8)+" ' ! Diese Procedure wird f"+Chr$(129)+"rs encoden ben"+Chr$(148)+"tigt ! ' ' !hier wenn pos%=255*8 zielpos um 256 erh"+Chr$(148)+"hen ' platz f"+Chr$(129)+"r die L"+Chr$(132)+"nge des RASTADATABLOCK L"+Chr$(142)+"NGE freihalten ' und deren position in ' !Rastadatalangadr% ' speichern ' Local I&,Adr% ' ' --------------------------------- ' Kann eigentlich nicht vorkommen!!!! ' If 2^Codelen&<Code& !!! sollte nicht auftreten k"+Chr$(148)+"nnen! If Hochbasis2%(Codelen&)<Code& !!!=sollte nicht auftreten k"+Chr$(148)+"nnen!(optimiert) Print ""+Chr$(27)+"pIn Putcode: Codelen zu klein f"+Chr$(129)+"r code (Codelen:";Codelen&;" code:";Code&;")"+Chr$(27)+"q" Else ' --------------------------------- ' For I&=0 To Codelen&-1 If Pos%+I&=255*8 !RastaDataBlock hat max l"+Chr$(132)+"nge Byte{Rastadatablocklang%}=255 ! Der jetzt abgeschlossene Block hat diese (maximale) L"+Chr$(132)+"nge Add Rastadatablocklang%,256 ! an diese Adresse wird sp"+Chr$(132)+"ter die l"+Chr$(132)+"nge des nun beginenden Blocks geschrieben Add Ziel%,256 Sub Pos%,8*255 Endif ' ' Adr%=Ziel%+(Pos%+I&) Div 8 Adr%=Ziel%+Shr((Pos%+I&),3) ! optimiert If Btst(Code&,I&) ' Byte{Adr%}=Bset(Byte{Adr%},(Pos%+I&) Mod 8) Byte{Adr%}=Bset(Byte{Adr%},(Pos%+I&) And 7) ! optimiert Else ' Byte{Adr%}=Bclr(Byte{Adr%},(Pos%+I&) Mod 8) Byte{Adr%}=Bclr(Byte{Adr%},(Pos%+I&) And 7) ! optimiert Endif Next I& Add Pos%,Codelen& Endif Return ' Procedure Analyse(Quell%,Ziel%) !!!in V 074 nicht korrekt (mu"+Chr$(158)+" angepasst werden) Local Signature$,Breit&,Hoch&,B5_10&,I&,Oldquell% Oldquell%=Quell% ! um zu sehen, wie viel schon ausgelesen wurde ' Print "------------Gif signature" ' Gif signature Signature$="123456" Bmove Quell%,V:Signature$,6 Print ""+Chr$(27)+"pGIF87a"+Chr$(27)+"q",Signature$ Add Quell%,6 ' ' screendiscripter Print "----------screendiscripter" Breit&=Byte{Quell%}+Byte{Quell%+1}*256 Hoch&=Byte{Quell%+2}+Byte{Quell%+3}*256 Print ""+Chr$(27)+"pSchirm-Breit (640):"+Chr$(27)+"q",Breit& Print ""+Chr$(27)+"pSchirm-Hoch (400):"+Chr$(27)+"q",Hoch& Print ""+Chr$(27)+"pbyte5 : (10000000)"+Chr$(27)+"q",Bin$(Byte{Quell%+4}) Print ""+Chr$(27)+"pbackground "+Chr$(27)+"q",Byte{Quell%+5} Print ""+Chr$(27)+"pNull: (00000000)"+Chr$(27)+"q",Bin$(Byte{Quell%+6}) Add Quell%,7 ' Print "----------global color map" ' global color map Print ""+Chr$(27)+"pFarbe 0 ROT : ( 0)"+Chr$(27)+"q",(Byte{Quell%}) Print ""+Chr$(27)+"pFarbe 0 gr"+Chr$(129)+"n: ( 0)"+Chr$(27)+"q",(Byte{Quell%+1}) Print ""+Chr$(27)+"pFarbe 0 blau: ( 0)"+Chr$(27)+"q",(Byte{Quell%+2}) Print ""+Chr$(27)+"pFarbe 1 ROT : (255)"+Chr$(27)+"q",(Byte{Quell%+3}) Print ""+Chr$(27)+"pFarbe 1 gr"+Chr$(129)+"n: (255)"+Chr$(27)+"q",(Byte{Quell%+4}) Print ""+Chr$(27)+"pFarbe 1 blau: (255)"+Chr$(27)+"q",(Byte{Quell%+5}) Add Quell%,6 ' -> ' ~Inp(2) While Chr$(Byte{Quell%})<>";" If Chr$(Byte{Quell%})="!" Print "----------gif expension block" Print ""+Chr$(27)+"p! = expansion block"+Chr$(27)+"q";Chr$(Byte{Quell%}) Print ""+Chr$(27)+"pfunction code"+Chr$(27)+"q";Byte{Quell%+1} Print ""+Chr$(27)+"pbyte count"+Chr$(27)+"q";Byte{Quell%+2} A$=Space$(Byte{Quell%+2}) Bmove Quell%+3,V:A$,Byte{Quell%+2} Print "!";A$;"!" Add Quell%,3+Byte{Quell%+2}+1 ' Else if Chr$(Byte{Quell%})="," ' image descriptor Print ""+Chr$(27)+"pImage seperator : (,)"+Chr$(27)+"q",Chr$(Byte{Quell%}) Left&=Byte{Quell%+1}+Byte{Quell%+2}*256 Top&=Byte{Quell%+3}+Byte{Quell%+4}*256 Width&=Byte{Quell%+5}+Byte{Quell%+6}*256 Height&=Byte{Quell%+7}+Byte{Quell%+8}*256 Print ""+Chr$(27)+"pleft (0):"+Chr$(27)+"q",Left& Print ""+Chr$(27)+"ptop (0):"+Chr$(27)+"q",Top& Print ""+Chr$(27)+"pbildbreit (16):"+Chr$(27)+"q",Width& Print ""+Chr$(27)+"pbildh"+Chr$(148)+"he (16):"+Chr$(27)+"q",Height& Print ""+Chr$(27)+"pbyte10: (00000000)"+Chr$(27)+"q",Bin$(Byte{Quell%+9}) Add Quell%,10 ' Print "----------local color map" ' local color map ' Print "-------rasra data" ' rasta data ' ^-- Print ""+Chr$(27)+"p code size (2)"+Chr$(27)+"q",Byte{Quell%} Codelen&=Byte{Quell%}+1 !bei uns hier immer 2+1=3 Bits Inc Quell% ' Rastablocklang&=1 !nach sovielen Bytes beginnt eventuell ein neuer RastaDataBlock (sofort der erste) ' T%=Timer @Decodebin_neu(Xbios(2),80,Width&,0,Quell%) !decode binversion3 ' Print At(1,1); Print "Zeitbedarf:";(Timer-T%)/200;"s" Print "Zeitbedarf:";(Timer-T%)/200/60;"min" Print "Zeitbedarf:";(Timer-T%)/200/60/60;"h" ' Print ""+Chr$(27)+"p Null "+Chr$(27)+"q",Byte{Quell%} Inc Quell% Else Print ""+Chr$(27)+"punbekannter Block im GIF: "+Chr$(27)+"q",Chr$(Byte{Quell%});"-";(Byte{Quell%});"-" Inc Quell% Endif ' ~Inp(2) ' Cls Wend ' Print "--------------gif terminator" ' gif termionator Print ""+Chr$(27)+"p GIF Terminator (;)"+Chr$(27)+"q",Chr$(Byte{Quell%}) Return ' ' *-----------------------------------------* ' | F"+Chr$(129)+"r die Bit-basierte Version (aktuelle) | (mit doppeltverkettetem Baum) ' *-----------------------------------------* ' Durch den doppeltverketteten Baum des Codetables mu"+Chr$(158)+" in der Tabelle nicht ' gesucht werden, sondern beim lesen der Pixel nur der Baum verfolgt werden. Procedure Addcode(Last&,K!,Var Next&) ! "+Chr$(8)+" 07.03.1999 fehler in der Parameterbezeichnung behoben (hatte keine Auswirkungen) Next&(-K!,Last&)=Next& Pref&(Next&)=Last& Next&(0,Next&)=-1 !noch keine Nachfolger Next&(1,Next&)=-1 !noch keine Nachfolger Lange&(Next&)=Lange&(Last&)+1 !l"+Chr$(132)+"nge des Codes !NEU ab V2_064 Inc Next& Return Procedure Codeinitbin2(Var Next&) ! "+Chr$(8)+" Next&(0,4)=0 ! 4 wird als wurzel betrachetet (code ohne pixel) Next&(1,4)=1 Pref&(0)=4 !4 = <CC> = kein Pixel Pref&(1)=4 !4 = <CC> = kein Pixel Lange&(0)=1 !l"+Chr$(132)+"nge des Codes Lange&(1)=1 !l"+Chr$(132)+"nge des Codes Next&(0,0)=-1 !Nachfolger existiert noch nicht Next&(1,0)=-1 !Nachfolger existiert noch nicht Next&(0,1)=-1 !Nachfolger existiert noch nicht Next&(1,1)=-1 !Nachfolger existiert noch nicht Next&=6 Codelen&=3 Return Procedure Putcodepixel(Ziel%,Code&,Var Pos%) ! "+Chr$(8)+" 45% des decoden Local Pos2% ' Add Pos%,Lange&(Code&) Pos2%=Pos%-1 ' While Code&<>4 Adr%=Ziel%+Shr(Pos2%,3) !optimiert If Next&(0,Pref&(Code&))=Code& ! jetzt ein 0 BIT Byte{Adr%}=Bclr(Byte{Adr%},7 Xor (Pos2% And 7)) !optimiert Else ! jetzt ein 1 BIT Byte{Adr%}=Bset(Byte{Adr%},7 Xor (Pos2% And 7)) !optimiert Endif Code&=Pref&(Code&) Dec Pos2% Wend Return FUNCTION Firstpixel(Code&) !"+Chr$(8)+" (bringt nichts dies dierekt in den Code zu kopieren) ' liefert TRUE wenn das erste Pixel von code gesetzt ist ' = -1 While Pref&(Code&)<>4 Code&=Pref&(Code&) Wend Return Next&(1,Pref&(Code&))=Code& Endfunc ' -------------------- ' zur ausgabe (debugging) Procedure Tableptint !"+Chr$(8)+" (Debugging: Liefert die CodeTabelle) Local I& For I&=0 To Min(23,Next&-1) Print At(40,I&+1);I&;":"; @Codeprint(I&) Next I& Return Procedure Codeprint(I&) !"+Chr$(8)+" (Gibt einen Eintrag der CodeTabelle aus) If I&<>4 @Codeprint(Pref&(I&)) If I&=Next&(1,Pref&(I&)) Print "1"; Else Print "0"; Endif Endif Return ' ' Procedure Makex_y(X&,Y&,Quell%,Ziel%,Xb_breit&) !"+Chr$(8)+"mit fehlerabfragen (einige) ' Put f"+Chr$(129)+"r Gif-Comprimierte Bilder ' X& :X-Koodinate im Ziel (in Pixel) ' Y& :Y-Koodinate im Ziel (in Pixel) ' Quell% :Startadresse des komprimierten Bildes ' Ziel% :Adresse des Ausgabe-Ziels (z.B. XBIOS(2) oder ein Put-String(dabnn abder +6 wegen header)) ' Xb_brterit :Abstand zweier untereinander liegender Zeilen im Ziel (in Bytes) beim Bildschirm 80 ' Local Signature$,Breit&,Hoch&,B5_10&,I&,Oldquell%,Hell1&,Hell2& Local Nziel%,Nx& ' Oldquell%=Quell% ! um zu sehen, wie viel schon ausgelesen wurde ' Add Ziel%,Y&*Xb_breit& Add Ziel%,X& Div 8 X&=X& Mod 8 ' Signature$="123456" ! Speicherplatz f"+Chr$(129)+"r die Signatur vergleich Bmove Quell%,V:Signature$,6 ! signatur an diese Stelle kopieren If Signature$<>"GIF87a" ! Vergleich Print "Quelle ist kein GIF! Die Signatur sollte 'GIF87a' lauten, lautet aber: '";Signature$;"'" ~Inp(2) Goto Ende_makex_y ! Es ist Leider ein Fehler eingetreten Endif Add Quell%,6 ' screendiscripter Breit&=Byte{Quell%}+Byte{Quell%+1}*256 !Bildbreite Hoch&=Byte{Quell%+2}+Byte{Quell%+3}*256 !Bildh"+Chr$(148)+"he ' Print ""+Chr$(27)+"pSchirm-Breit (640):"+Chr$(27)+"q",Breit& ' Print ""+Chr$(27)+"pSchirm-Hoch (400):"+Chr$(27)+"q",Hoch& ' Print ""+Chr$(27)+"pbyte5 : (10000000)"+Chr$(27)+"q",Bin$(Byte{Quell%+4}) ' Print ""+Chr$(27)+"pbackground "+Chr$(27)+"q",Byte{Quell%+5} ' Print ""+Chr$(27)+"pNull: (00000000)"+Chr$(27)+"q",Bin$(Byte{Quell%+6}) If Byte{Quell%+6}<>0 ! Print "1. Datenfehler in der Quelle" ~Inp(2) Goto Ende_makex_y ! Es ist Leider ein Fehler eingetreten Endif Add Quell%,7 ' ' global color map ' Print ""+Chr$(27)+"pFarbe 0 ROT : ( 0)"+Chr$(27)+"q",(Byte{Quell%}) ' Print ""+Chr$(27)+"pFarbe 0 gr"+Chr$(129)+"n: ( 0)"+Chr$(27)+"q",(Byte{Quell%+1}) ' Print ""+Chr$(27)+"pFarbe 0 blau: ( 0)"+Chr$(27)+"q",(Byte{Quell%+2}) ' Print ""+Chr$(27)+"pFarbe 1 ROT : (255)"+Chr$(27)+"q",(Byte{Quell%+3}) ' Print ""+Chr$(27)+"pFarbe 1 gr"+Chr$(129)+"n: (255)"+Chr$(27)+"q",(Byte{Quell%+4}) ' Print ""+Chr$(27)+"pFarbe 1 blau: (255)"+Chr$(27)+"q",(Byte{Quell%+5}) Hell1&=Byte{Quell%}+Byte{Quell%+1}+Byte{Quell%+2} ! Farbwerte eibnlesen Add Quell%,3 Hell2&=Byte{Quell%}+Byte{Quell%+1}+Byte{Quell%+2} ! Farbwerte eibnlesen Add Quell%,3 ' Print "Farben";Hell1&;"|";Hell2&;"|" If Hell1&<Hell2& !\ Farbe1&=1 ! \ Else ! > hellere Farbe wird zu wei"+Chr$(158)+" dunklere zu schwarz Farbe1&=0 ! / bei der ausgabe Endif !/ ' -> While Chr$(Byte{Quell%})<>";" !Mehrere Bilder in der Quelle m"+Chr$(148)+"glich!!! If Chr$(Byte{Quell%})="!" A$=Space$(Byte{Quell%+2}) Add Quell%,3+Byte{Quell%+2}+1 Else if Chr$(Byte{Quell%})="," ' image descriptor Left&=Byte{Quell%+1}+Byte{Quell%+2}*256 Top&=Byte{Quell%+3}+Byte{Quell%+4}*256 ' Nziel%=Ziel%+Top&*Xb_breit& Nx&=X&+Left& Add Nziel%,Nx& Div 8 Nx&=Nx& Mod 8 ' Breit&=Byte{Quell%+5}+Byte{Quell%+6}*256 Hoch&=Byte{Quell%+7}+Byte{Quell%+8}*256 Add Quell%,10 ' local color map !wird nicht unterst"+Chr$(129)+"tzt!!!! ' ' rasta data Codelen&=Byte{Quell%}+1 !bei uns hier immer 2+1=3 Bits If Codelen&<>3 Print "GIF! hat nichtunterst"+Chr$(129)+"tzte Code-L"+Chr$(132)+"nge! " ~Inp(2) Goto Ende_makex_y Endif Inc Quell% ' Rastablocklang&=1 !nach sovielen Bytes beginnt eventuell ein neuer RastaDataBlock (sofort der erste) ' @Decodebin_neu(Nziel%,Xb_breit&,Breit&,Nx&,Quell%) Else Print ""+Chr$(27)+"punbekannter Block im GIF: "+Chr$(27)+"q",Chr$(Byte{Quell%});"-";(Byte{Quell%});"-" Inc Quell% ~Inp(2) Endif Wend ' gif termionator If Chr$(Byte{Quell%})<>";" Print "GIF hat keine g"+Chr$(129)+"ltige Endmakierung! soll:';' ist:'";Chr$(Byte{Quell%});"'" ~Inp(2) Endif Ende_makex_y: !Sprungziel f"+Chr$(129)+"r fehler Return ' ' mit debuggingausgaben! Procedure Decodebin_neu(Ziel%,Xb_breit&,Bildbreit&,Nx&,Var Quell%) ' Ziel% :Zieladresse (in diesem Byte kommt der erste Pixxel (7-nx%)=position im Byte) ' Xb_breit& :Zeilenabstand im Ziel (in Byte) (640 Pixel = 80 Byte) ' Nx& :Pixeloffset im Zielbyte (0 bis 7) ' Quell% :Adresse der komprimierten Ausgangsdaten ' Local Bitpos%,Zielpos%,K! ' Zielpos%=0 !Position in der Ausagabe (bisher noch nichts ausgegeben) Bitpos%=0 !Soweit ist der Codestream schon ausgewertet! (0 <=> noch garnicht) Old&=4 !noch kein alter code vorhanden Do Code&=@Getcode_neu(Codelen&,Quell%,Bitpos%) !! falsche adresse!!! If Code&=5 Print At(1,14);"ENDE des RastecodeBlocks Erreicht!" Exit if True Else if Code&=4 !INIT @Codeinitbin2(Next&) Else if Code&<Next& !!!! code schon im Codetable @Putcodepixel_neu(Code&,Xb_breit&,Bildbreit&,Nx&,Ziel%,Zielpos%) If Old&<>4 !! dieser Code ist bekannt K!=@Firstpixel(Code&) @Addcode(Old&,K!,Next&) Endif Else !! dieser Code bislang unbekannt K!=@Firstpixel(Old&) @Addcode(Old&,K!,Next&) !!Code in die Codetable eintragen @Putcodepixel_neu(Code&,Xb_breit&,Bildbreit&,Nx&,Ziel%,Zielpos%) Endif Old&=Code& If Next&=2^Codelen& !L"+Chr$(132)+"nge der Codes mu"+Chr$(158)+" erh"+Chr$(148)+"ht werden Inc Codelen& Endif ' Print At(60,1);"bitpos :";Bitpos% ' Print At(60,2);"zielpos:";Zielpos% ' @Tableptint Loop Print At(1,15) Print Bitpos% Add Quell%,Shr(Bitpos%+7,3)+Rastablocklang& ' Print "rastablockrest:";Rastablocklang&;" " Print "putcodepixel :";Putcodepixel%;" " Print "getcode :";Getcode%;" " Print "gesammt : ";Timer-T%;" " ' ' Let Putcodepixel%=0 Let Getcode%=0 ' ' ~Inp(2) Return ' ' putcodepixel mu"+Chr$(158)+" noch erweitert werden - interlace ' "+Chr$(8)+" in 3_073 noch mehr als 50% der Zeit PROCEDURE Putcodepixel_neu(Code&,Xb_breit&,Bildbreit&,Nx&,Var Ziel%,Pos%) ' Parameter: ' Code& :Der Code, der angibt welche Pixel ausgegeben werden m"+Chr$(129)+"ssen ' Xb_breit& :Zeilenl"+Chr$(132)+"nge des Zieles in Bytes (80 beim Bildschirm) ' Bildbreit& :Breite des Bildes in Pixeln ' Nx& :Pixeloffsdet des auszugebenden Bildes vom linken Rand ' Ziel% :Adresse des Zieles (z.B. Bildschirm: xbios(29+y*80) ' Pos% :Position in den codierten daten (in Pixel) ' ' !!!Optimierung, sollte sicher sein, da"+Chr$(158)+" das Ziel weiss ist kann unten ein ' Fall (wei"+Chr$(158)+"en Pixel malen verzichtet werden! ) ' Local Pos2%,Pos3% Local Swap%,Xb_breit8%,Pos2_mod_bb& Xb_breit8%=Xb_breit&*8 ' ' T2%=Timer !!!!!!!!!!!!!!!!!!!!!!Analyse des Laufzeitanteils ' ' Add Pos%,Lange&(Code&) !position im komprimierten auf den n"+Chr$(132)+"chsten code setzen Pos2%=Pos%-1 !zur optimierung (da Pos%-1 "+Chr$(148)+"fter gebraucht wird) ' Swap%=((Pos2% Div Bildbreit&))*Xb_breit8%+Nx& Pos2_mod_bb&=(Pos2% Mod Bildbreit&) !zur optimierung (Wert wird mehrfach ben"+Chr$(148)+"tigt) While Code&<>4 ' ' Pos3%=(Pos2% Mod Bildbreit&)+Swap% Pos3%=Pos2_mod_bb&+Swap% !optimiert (entspricht der vorigen Zeile) ' Adr%=Ziel%+Shr(Pos3%,3) !optimiert If Next&(Farbe1&,Pref&(Code&))<>Code& !jetzt ein 1 BIT Byte{Adr%}=Bset(Byte{Adr%},7 Xor (Pos3% And 7)) !optimiert Else !jetzt ein 0 BIT ' !!! Optimierung m"+Chr$(148)+"glich! ' den else-fall kann man entfernen, wenn er reicht das Bild im OR-Modus ' auszugeben (z.B. weil sichergestellt ist, da"+Chr$(158)+" das Ziel bereits eine ' Weisse fl"+Chr$(132)+"che ist Byte{Adr%}=Bclr(Byte{Adr%},7 Xor (Pos3% And 7)) !optimiert Endif Code&=Pref&(Code&) If Pos2_mod_bb&=0 Pos2_mod_bb&=Bildbreit& Sub Swap%,Xb_breit8% Endif Dec Pos2_mod_bb& Wend ' ' Add Putcodepixel%,Timer-T2% !!!!!!!!!!!!!!!!!!!!!!Analyse des Laufzeitanteils ' ' Return ' FUNCTION Getcode_neu(Codelen&,Var Quell%,Pos%) !"+Chr$(8)+" ' ' T2%=Timer !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ' ' ' - ber"+Chr$(129)+"cksichtigt mehrere RastaDataBlocks ' Byte1 Byte2 Byte3 ' HGFEDCBA PONMLKJI XWVUTSRQ ....... ' ^ Pos 0 ^ Pos 16 ' Beispiel: getcode(adr%,10,7) ' Liefert : K+2*(L+2*(M+2*(N+2*(O+2*(P+2*(Q)))))) ' Local Wert&,I& Wert&=0 For I&=0 To Codelen&-1 If (Pos% And 7)=0 !pos% mod 8 = 0 (gleich) Dec Rastablocklang& !soviele Bytes bis neuer RastaDataBlock If Rastablocklang&=0 !Ende des rasta data blocks Add Quell%,Shr(Pos%,3) Pos%=8 !L"+Chr$(132)+"ngenangabe "+Chr$(129)+"berlesen Rastablocklang&=Byte{Quell%} !L"+Chr$(132)+"nge des n"+Chr$(132)+"chsetn Blocks ' ' !!!!!!!!!!!!! Sollte nie vorkommen !!!!!!!!!!!!!! ' If Rastablocklang&=0 !!sollte nicht vorkommen <EOI> sollte gekommen sein ' Print "Fehler in getcode: es kam kein <EOI> obwohl n"+Chr$(132)+"chster Block l"+Chr$(132)+"nge 0!" ' ~Inp(2) ' Endif ' Endif Endif If Btst(Byte{Quell%+Shr(Pos%,3)},Pos% And 7) ! optimiert Wert&=Wert&+Hochbasis2%(I&) Endif Inc Pos% Next I& ' Add Getcode%,Timer-T2% ' Return Wert& Endfunc ' ' ' Wissenswertes: ' *************** ' - Zum GIF Format: ' *************** ' keinerlei Makierung des Endes eines RastaDataBlocks im Codestream ' - es wird einfach das eine Byte (l"+Chr$(132)+"nge des n"+Chr$(132)+"chsten Blocks) ' "+Chr$(129)+"bersprungen, so da"+Chr$(158)+" unter Umst"+Chr$(132)+"nden Bits aus dem alten RastaData ' Block zusammen mit Bits aus dem n"+Chr$(132)+"chsten Rasta DataBlocks den ' n"+Chr$(132)+"chsten Code ergeben!!! ' ' - PSP erzeugt aus irgendwelchen Gr"+Chr$(129)+"nden RasrterDataBlocks mit einer ' maximalgr"+Chr$(148)+""+Chr$(158)+"e von 254 Bytes (obwohl 255 erlaubt sind und funktionieren ' (PSP und Netscape k"+Chr$(148)+"nnen diese Bilder dekodieren/anzeigen!)) ' - PSP benutzt "greedy" codierung (keine besonders rafinierte optimierung ' aber optimal bei unendlicher Bildgr"+Chr$(148)+""+Chr$(158)+"e und unendlicher ' Codetablellen-L"+Chr$(132)+"nge) ' (ich verwende (da gut und einfach) die gleiche (momentarn)) ' ' ------------------------------------------------------------------------- ' diese Funktionen wurden direkt in den Code eingesetzt! ' (inline von Hand sozusagen!) ' ' Function Searchcode(Last&,Pixel!) ! "+Chr$(8)+" f"+Chr$(129)+"r decode ' ' -Sucht den um pixel verl"+Chr$(132)+"ngerten code in der nummer last ' ' -gibt die nummer des um pixel verl"+Chr$(132)+"ngerten codes (-1) bedeutet gibts nicht ' ' pixel! <=> K! ' ' last& <=> nummer con ppp$ ' ' ' Return Next&(-Pixel!,Last&) ' ' ' Endfunc ' ' !!interlace fehlt noch!! f"+Chr$(129)+"r encode ' ' Function Getpixel(Breit&,Hoch&,Z_off&,Var Quell%,Quellpos%,Zeile&) !"+Chr$(8)+" !!!interlace fehlt noch!! ' ' liefert TRUE, wenn pixel schwarz ' ' !!! hier sp"+Chr$(132)+"ter INTERLACE implementieren (durch ber"+Chr$(129)+"cksuichtigung von Zeile und hoch) ' ' ' Local Pixel! ' If Quellpos%=Breit& !N"+Chr$(132)+"chste Zeile beginnt nun! ' Add Quell%,Z_off& !Quelladresse korregieren !!! hier f"+Chr$(129)+"r interlace "+Chr$(132)+"ndern ' Quellpos%=0 !Nun wieser am Zeilenanfang! ' Inc Zeile& !neue Zeile ' Endif ' ' Pixel!=Btst(Byte{Quell%+Quellpos% Div 8},7-(Quellpos% Mod 8)) ' Pixel!=Btst(Byte{Quell%+Shr(Quellpos%,3)},7 Xor (Quellpos% And 7)) ! optimiert ' Inc Quellpos% !n"+Chr$(132)+"chstes Mal n"+Chr$(132)+"chster Pixel ' Return Pixel! ' Endfunc |
| Legende: | ||||||
|---|---|---|---|---|---|---|
| Ä | ersetzt durch | "Chr$(142)" | ||||
| Ü | ersetzt durch | "Chr$(154)" | ||||
| ß | ersetzt durch | "Chr$(158)" | ||||
| ä | ersetzt durch | "Chr$(132)" | ||||
| ö | ersetzt durch | "Chr$(148)" | ||||
| ü | ersetzt durch | "Chr$(129)" | ||||
| nicht-ASCII 8 | ersetzt durch | "Chr$(8)" | ||||
| nicht-ASCII 27 | ersetzt durch | "Chr$(27)" | ||||
| nicht-ASCII 255 | ersetzt durch | "Chr$(255)" | ||||
| legend: | ||||||
|---|---|---|---|---|---|---|
| Ä | replaced by | "Chr$(142)" | ||||
| Ü | replaced by | "Chr$(154)" | ||||
| ß | replaced by | "Chr$(158)" | ||||
| ä | replaced by | "Chr$(132)" | ||||
| ö | replaced by | "Chr$(148)" | ||||
| ü | replaced by | "Chr$(129)" | ||||
| non-ASCII 8 | replaced by | "Chr$(8)" | ||||
| non-ASCII 27 | replaced by | "Chr$(27)" | ||||
| non-ASCII 255 | replaced by | "Chr$(255)" | ||||
zurück zur GFA-BASIC-Seite des Folkes
zurück zur Programmier-Seite des Folkes
zurück zur Startseite des Folkes
| Lage dieser Seite: | "http://www.Rinneberg.de/programming/gfa.htm" |
| "http://www.Folke-Rinneberg.de/programming/gfa.htm" |
