…Show last 1476 lines
61 function DetectVGA: Boolean;
62 procedure InitVGA;
63 procedure OldMode;
64 function GetMode: Byte;
65 procedure SetMode (NewMode: Byte);
66 procedure ClearVGAMem;
67 procedure WaitDisplay;
68 procedure WaitRetrace;
69 procedure SetView (X, Y: Integer);
70 procedure SetViewport (X, Y: Integer; PageNr: Byte);
71 procedure SwapPages;
72 procedure ShowPage;
73 procedure Border (Attr: Byte);
74 procedure SetYStart (NewYStart: Integer);
75 procedure SetYEnd (NewYEnd: Integer);
76 procedure SetYOffset (NewYOffset: Integer);
77 function GetYOffset: Integer;
78 procedure PutPixel (X, Y: Integer; Attr: Byte);
79 function GetPixel (X, Y: Integer): Byte;
80 procedure DrawImage (XPos, YPos, Width, Height: Integer; var BitMap);
81 procedure RecolorImage (XPos, YPos, Width, Height: Integer; var BitMap; Diff: Byte);
82 procedure DrawPart (XPos, YPos, Width, Height, Y1, Y2: Integer; var BitMap);
83 procedure UpSideDown (XPos, YPos, Width, Height: Integer; var BitMap);
84 procedure PutImage (XPos, YPos, Width, Height: Integer; var BitMap);
85 procedure GetImage (XPos, YPos, Width, Height: Integer; var BitMap);
86 procedure Fill (X, Y, W, H: Integer; Attr: Integer);
87 procedure SetPalette (Color, Red, Green, Blue: Byte);
88 procedure ReadPalette (var NewPalette);
89 procedure ClearPalette;
90 function CurrentPage: Integer;
91 function GetPageOffset: Word;
92 procedure ResetStack;
93 function PushBackGr (X, Y, W, H: Integer): Word;
94 procedure PopBackGr (Address: Word);
95 procedure DrawBitmap (X, Y: Integer; var BitMap; Attr: Byte);
96
97 const
98 InGraphicsMode: Boolean = FALSE;
99
100implementation
101
102 var
103 OldExitProc: Pointer;
104 OldScreenMode: Byte;
105
106 const
107 XView: Integer = 0;
108 YView: Integer = 0;
109
110 Page: Integer = 0;
111 PageOffset: Word = 0;
112
113 YOffset: Integer = 0;
114
115 SAFE = 34 * BYTES_PER_LINE;
116
117 Stack: array[0..MAX_PAGE] of Word =
118 (PAGE_0 + PAGE_SIZE + SAFE,
119 PAGE_1 + PAGE_SIZE + SAFE);
120
121
122 {$F+}
123 procedure NewExitProc;
124 { Be sure to return to textmode if program is halted }
125 begin
126 OldMode;
127 ExitProc := OldExitProc;
128 end;
129 {$F-}
130
131 function GetMode: Byte;
132 { Get video mode }
133 begin
134 asm
135 push bp
136 mov ah, 0Fh
137 int 10h
138 mov @Result, al
139 pop bp
140 end;
141 end;
142
143 procedure SetMode (NewMode: Byte);
144 { Set video mode }
145 begin
146 asm
147 push bp
148 xor ah, ah
149 mov al, NewMode
150 int 10h
151 pop bp
152 end;
153 end;
154
155 procedure SetWidth (NewWidth: Word);
156 { Set screen width (NewWidth >= 40) }
157 begin
158 asm
159 mov ax, NewWidth
160 push ax
161 mov dx, CRTC_INDEX
162 mov ax, 13h
163 out dx, al
164 pop ax
165 inc dx
166 out dx, al
167 end;
168 end;
169
170 function DetectVGA: Boolean;
171 var
172 VGADetected: Boolean;
173 begin
174 VGADetected := False;
175 asm
176 push bp
177 mov ax, 1A00h
178 int 10h
179 cmp al, 1Ah
180 jnz @NoVGA
181 inc VGADetected
182 @NoVGA:
183 pop bp
184 end;
185 DetectVGA := VGADetected;
186 end;
187
188 procedure InitVGA;
189 { Start graphics mode 320x200 256 colors }
190 begin
191 ClearPalette;
192 SetMode ($13);
193 ClearPalette;
194 SetWidth (BYTES_PER_LINE shr 1);
195 asm
196 mov dx, SC_INDEX
197 mov al, MEMORY_MODE
198 out dx, al
199 inc dx
200 in al, dx
201 and al, not 8
202 or al, 4
203 out dx, al
204 mov dx, GC_INDEX
205 mov al, GRAPHICS_MODE
206 out dx, al
207 inc dx
208 in al, dx
209 and al, not 10h
210 out dx, al
211 dec dx
212 mov al, MISCELLANEOUS
213 out dx, al
214 inc dx
215 in al, dx
216 and al, not 2
217 out dx, al
218 end;
219 ClearVGAMem;
220 asm
221 mov dx, CRTC_INDEX
222 mov al, UNDERLINE
223 out dx, al
224 inc dx
225 in al, dx
226 and al, not 40h
227 out dx, al
228 dec dx
229 mov al, MODE_CONTROL
230 out dx, al
231 inc dx
232 in al, dx
233 or al, 40h
234 out dx, al
235 end;
236 if not InGraphicsMode then
237 begin
238 OldExitProc := ExitProc;
239 ExitProc := @NewExitProc;
240 end;
241 InGraphicsMode := TRUE;
242 end;
243
244 procedure OldMode;
245 { Return to the original screenmode }
246 begin
247 if InGraphicsMode then
248 begin
249 ClearVGAMem;
250 ClearPalette;
251 ShowPage;
252 end;
253 SetMode (OldScreenMode);
254 InGraphicsMode := FALSE;
255 ExitProc := OldExitProc;
256 end;
257
258 procedure ClearVGAMem;
259 begin
260 asm
261 push es
262 mov dx, SC_INDEX
263 mov ax, 0F00h + MAP_MASK
264 out dx, ax
265 mov ax, VGA_SEGMENT
266 mov es, ax
267 xor ax, ax
268 mov di, ax
269 mov cx, 8000h
270 cld
271 rep stosw
272 pop es
273 end;
274 end;
275
276 procedure WaitDisplay;
277 begin
278 asm
279 mov dx, VERT_RESCAN
280 @1: in al, dx
281 test al, VERT_RETRACE_MASK
282 jnz @1
283 end;
284 end;
285
286 procedure WaitRetrace;
287 begin
288 asm
289 mov dx, VERT_RESCAN
290 @1: in al, dx
291 test al, VERT_RETRACE_MASK
292 jz @1
293 end;
294 end;
295
296 procedure SetView (X, Y: Integer);
297 begin
298 XView := X;
299 YView := Y;
300 end;
301
302 procedure SetViewport (X, Y: Integer; PageNr: Byte);
303 { Set the offset of video memory }
304 var
305 i: Integer;
306 begin
307 asm
308 cli
309
310 mov dx, VERT_RESCAN { wait for display }
311 @1: in al, dx
312 test al, VERT_RETRACE_MASK
313 jnz @1
314
315 shl X, 1
316 shl Y, 1
317 mov ax, Y
318 mov bx, BYTES_PER_LINE / 2
319 mul bx
320 mov bx, X
321 mov cl, 3
322 shr bx, cl
323 add bx, ax
324 mov al, START_ADDRESS_HIGH
325 mov ah, PageNr
326 ror ah, 1
327 add ah, bh
328 mov dx, CRTC_INDEX
329 out dx, ax
330 mov al, START_ADDRESS_LOW
331 mov ah, bl
332 out dx, ax
333
334 mov dx, VERT_RESCAN { wait for retrace }
335 @2: in al, dx
336 test al, VERT_RETRACE_MASK
337 jz @2
338
339 mov ax, X
340 and ax, 7
341 add al, 10h
342 mov dx, 3c0h
343 mov ah, al
344 mov al, 33h
345 out dx, al
346 xchg ah, al
347 out dx, al
348 sti
349 end;
350 end;
351
352 procedure SwapPages;
353 begin
354 case Page of
355 0: begin
356 Page := 1;
357 PageOffset := PAGE_1 + YOffset * BYTES_PER_LINE;
358 end;
359 1: begin
360 Page := 0;
361 PageOffset := PAGE_0 + YOffset * BYTES_PER_LINE;
362 end;
363 end;
364 end;
365
366 procedure ShowPage;
367 begin
368 SetViewport (XView, YView, Page);
369 SwapPages;
370 end;
371
372 procedure Border (Attr: Byte);
373 { Draw a border around the screen }
374 begin
375 asm
376 push bp
377 mov ax, 1001h
378 mov bh, Attr
379 int 10h
380 pop bp
381 end;
382 end;
383
384 procedure SetYStart (NewYStart: Integer);
385 begin
386 asm
387 mov dx, CRTC_INDEX
388 mov al, 16h
389 mov ah, Byte Ptr [NewYStart]
390 and ah, 7Fh
391 out dx, ax
392 end;
393 end;
394
395 procedure SetYEnd (NewYEnd: Integer);
396 begin
397 asm
398 mov dx, CRTC_INDEX
399 mov al, 15h
400 mov ah, Byte Ptr [NewYEnd]
401 out dx, ax
402 end;
403 end;
404
405 procedure SetYOffset (NewYOffset: Integer);
406 begin
407 YOffset := NewYOffset;
408 end;
409
410 function GetYOffset: Integer;
411 begin
412 GetYOffset := YOffset;
413 end;
414
415 procedure PutPixel (X, Y: Integer; Attr: Byte);
416 { Draw a single pixel at (X, Y) with color Attr }
417 begin
418 asm
419 push es
420 mov ax, VGA_SEGMENT
421 mov es, ax
422 mov dx, Y
423 mov ax, BYTES_PER_LINE
424 mul dx
425 mov cx, X
426 push cx
427 shr cx, 1
428 shr cx, 1
429 add ax, cx
430 mov di, ax
431 add di, PageOffset
432 pop cx
433 and cl, 3
434 mov ah, 1
435 shl ah, cl
436 mov al, MAP_MASK
437 mov dx, SC_INDEX
438 out dx, ax
439 mov al, Attr
440 stosb
441 pop es
442 end;
443 end;
444
445 function GetPixel (X, Y: Integer): Byte;
446 { Get color of pixel at (X, Y) }
447 begin
448 asm
449 push es
450 mov ax, VGA_SEGMENT
451 mov es, ax
452 mov dx, Y
453 mov ax, BYTES_PER_LINE
454 mul dx
455 mov cx, X
456 push cx
457 shr cx, 1
458 shr cx, 1
459 add ax, cx
460 mov si, ax
461 add si, PageOffset
462 pop ax
463 and al, 3
464 mov ah, al
465 mov al, READ_MAP
466 mov dx, GC_INDEX
467 out dx, ax
468 seges mov al, [si]
469 pop es
470 mov @Result, al
471 end;
472 end;
473
474 procedure DrawImage (XPos, YPos, Width, Height: Integer; var BitMap);
475 { Draw an image on the screen (NULL-bytes are ignored) }
476 begin
477 asm
478 push ds
479
480 mov ax, VGA_SEGMENT
481 mov es, ax
482
483 mov ax, YPos
484 cmp ax, VIR_SCREEN_HEIGHT
485 jb @NotNeg
486 jg @End
487 mov bx, ax
488 add bx, Height
489 jnc @End
490 @NotNeg:
491 mov bx, BYTES_PER_LINE
492 mul bx
493 mov di, XPos
494 mov bx, di
495 shr di, 1
496 shr di, 1
497 add di, ax { DI = (YPos * 80) + XPos / 4 }
498 add di, PageOffset
499
500 lds si, BitMap { Point to bitmap }
501
502 and bl, 3
503 mov cl, bl
504 mov ah, 1
505 shl ah, cl
506 sub bl, 4
507 mov cx, 4 { 4 planes }
508
509 @Plane:
510 push bx
511 push cx { Planes to go }
512 push ax { Mask in AH }
513
514 mov al, MAP_MASK
515 mov dx, SC_INDEX
516 out dx, ax
517
518 cld
519 push di
520 mov bx, Width
521 shr bx, 1
522 shr bx, 1
523 mov ax, BYTES_PER_LINE
524 sub ax, bx { Space before next line }
525 mov dx, Height
526 @Line:
527 mov cx, bx
528 shr cx, 1
529
530 push ax
531 pushf
532
533 @Pixel:
534 lodsw
535 or al, al
536 jz @Skip1
537 seges
538 mov [di], al
539 @Skip1:
540 inc di
541 or ah, ah
542 jz @Skip2
543 seges
544 mov [di], ah
545 @Skip2:
546 inc di
547 loop @Pixel
548
549 popf
550 rcl cx, 1
551 jcxz @Skip3
552
553 lodsb
554 or al, al
555 jz @Odd
556 stosb
557 jmp @Skip3
558 @Odd: inc di
559 @Skip3:
560 pop ax
561 add di, ax
562 dec dx
563 jnz @Line
564
565 pop di
566
567 pop ax
568 mov al, ah
569 mov cl, 4
570 shl al, cl
571 or ah, al { Mask for next byte }
572 rol ah, 1 { Bit mask for next plane }
573 pop cx { Planes }
574 pop bx
575 inc bl { Still in the same byte? }
576 adc di, 0
577 loop @Plane
578
579 @End:
580 pop ds
581 end;
582 end;
583
584 procedure RecolorImage (XPos, YPos, Width, Height: Integer; var BitMap; Diff: Byte);
585 begin
586 asm
587 push ds
588
589 mov ax, VGA_SEGMENT
590 mov es, ax
591
592 mov ax, YPos
593 cmp ax, VIR_SCREEN_HEIGHT
594 jb @NotNeg
595 jg @End
596 mov bx, ax
597 add bx, Height
598 jnc @End
599 @NotNeg:
600 mov bx, BYTES_PER_LINE
601 mul bx
602 mov di, XPos
603 mov bx, di
604 shr di, 1
605 shr di, 1
606 add di, ax { DI = (YPos * 80) + XPos / 4 }
607 add di, PageOffset
608
609 lds si, BitMap { Point to bitmap }
610
611 and bl, 3
612 mov cl, bl
613 mov ah, 1
614 shl ah, cl
615 sub bl, 4
616 mov cx, 4 { 4 planes }
617
618 @Plane:
619 push bx
620 push cx { Planes to go }
621 push ax { Mask in AH }
622
623 mov al, MAP_MASK
624 mov dx, SC_INDEX
625 out dx, ax
626
627 cld
628 push di
629 mov bx, Width
630 shr bx, 1
631 shr bx, 1
632 mov ax, BYTES_PER_LINE
633 sub ax, bx { Space before next line }
634 mov dx, Height
635 @Line:
636 mov cx, bx
637 shr cx, 1
638
639 push ax
640 pushf
641
642 @Pixel:
643 lodsw
644 or al, al
645 jz @Skip1
646 add al, Diff
647 seges
648 mov [di], al
649 @Skip1:
650 inc di
651 or ah, ah
652 jz @Skip2
653 add ah, Diff
654 seges
655 mov [di], ah
656 @Skip2:
657 inc di
658 loop @Pixel
659
660 popf
661 rcl cx, 1
662 jcxz @Skip3
663
664 lodsb
665 or al, al
666 jz @Odd
667 add al, Diff
668 stosb
669 jmp @Skip3
670 @Odd: inc di
671 @Skip3:
672 pop ax
673 add di, ax
674 dec dx
675 jnz @Line
676
677 pop di
678
679 pop ax
680 mov al, ah
681 mov cl, 4
682 shl al, cl
683 or ah, al { Mask for next byte }
684 rol ah, 1 { Bit mask for next plane }
685 pop cx { Planes }
686 pop bx
687 inc bl { Still in the same byte? }
688 adc di, 0
689 loop @Plane
690
691 @End:
692 pop ds
693 end;
694 end;
695
696 procedure DrawPart (XPos, YPos, Width, Height, Y1, Y2: Integer; var BitMap);
697 begin
698 asm
699 push ds
700 cmp Height, 0
701 jle @End
702
703 mov ax, VGA_SEGMENT
704 mov es, ax
705
706 mov ax, YPos
707 cmp ax, VIR_SCREEN_HEIGHT
708 jb @NotNeg
709 jg @End
710 mov bx, ax
711 add bx, Height
712 jnc @End
713 @NotNeg:
714 mov bx, BYTES_PER_LINE
715 mul bx
716 mov di, XPos
717 mov bx, di
718 shr di, 1
719 shr di, 1
720 add di, ax { DI = (YPos * 80) + XPos / 4 }
721 add di, PageOffset
722
723 lds si, BitMap { Point to bitmap }
724
725 and bl, 3
726 mov cl, bl
727 mov ah, 1
728 shl ah, cl
729 sub bl, 4
730 mov cx, 4 { 4 planes }
731
732 @Plane:
733 push bx
734 push cx { Planes to go }
735 push ax { Mask in AH }
736
737 mov al, MAP_MASK
738 mov dx, SC_INDEX
739 out dx, ax
740
741 cld
742 push di
743 mov bx, Width
744 shr bx, 1
745 shr bx, 1
746 mov ax, BYTES_PER_LINE
747 sub ax, bx { Space before next line }
748
749 xor dx, dx
750 @Line:
751 cmp dx, Y1
752 jl @EndLine
753 cmp dx, Y2
754 jg @EndLine
755
756 mov cx, bx
757 shr cx, 1
758
759 push ax
760 pushf
761
762 @Pixel:
763 lodsw
764 or al, al
765 jz @Skip1
766 seges
767 mov [di], al
768 @Skip1:
769 inc di
770 or ah, ah
771 jz @Skip2
772 seges
773 mov [di], ah
774 @Skip2:
775 inc di
776 loop @Pixel
777
778 popf
779 rcl cx, 1
780 jcxz @Skip3
781
782 lodsb
783 or al, al
784 jz @Odd
785 stosb
786 jmp @Skip3
787 @Odd: inc di
788 @Skip3:
789 pop ax
790 add di, ax
791 jmp @1
792
793 @EndLine:
794 add si, bx
795 add di, BYTES_PER_LINE
796
797 @1: inc dx
798 cmp dx, Height
799 jb @Line
800
801 pop di
802
803 pop ax
804 mov al, ah
805 mov cl, 4
806 shl al, cl
807 or ah, al { Mask for next byte }
808 rol ah, 1 { Bit mask for next plane }
809 pop cx { Planes }
810 pop bx
811 inc bl { Still in the same byte? }
812 adc di, 0
813 loop @Plane
814
815 @End:
816 pop ds
817 end;
818 end;
819
820 procedure UpSideDown (XPos, YPos, Width, Height: Integer; var BitMap);
821 { Draw an image on the screen up-side-down (NULL-bytes are ignored) }
822 begin
823 asm
824 push ds
825
826 mov ax, VGA_SEGMENT
827 mov es, ax
828
829 mov ax, YPos
830 cmp ax, VIR_SCREEN_HEIGHT
831 jb @NotNeg
832 jg @End
833 mov bx, ax
834 add bx, Height
835 jnc @End
836 @NotNeg:
837 add ax, Height
838 dec ax
839 mov bx, BYTES_PER_LINE
840 mul bx
841 mov di, XPos
842 mov bx, di
843 shr di, 1
844 shr di, 1
845 add di, ax { DI = (YPos * 80) + XPos / 4 }
846 add di, PageOffset
847
848 lds si, BitMap { Point to bitmap }
849
850 and bl, 3
851 mov cl, bl
852 mov ah, 1
853 shl ah, cl
854 sub bl, 4
855 mov cx, 4 { 4 planes }
856
857 @Plane:
858 push bx
859 push cx { Planes to go }
860 push ax { Mask in AH }
861
862 mov al, MAP_MASK
863 mov dx, SC_INDEX
864 out dx, ax
865
866 cld
867 push di
868 mov bx, Width
869 shr bx, 1
870 shr bx, 1
871 mov ax, BYTES_PER_LINE
872 add ax, bx { Space before next line }
873 mov dx, Height
874 @Line:
875 mov cx, bx
876 shr cx, 1
877
878 push ax
879 pushf
880
881 @Pixel:
882 lodsw
883 or al, al
884 jz @Skip1
885 seges
886 mov [di], al
887 @Skip1:
888 inc di
889 or ah, ah
890 jz @Skip2
891 seges
892 mov [di], ah
893 @Skip2:
894 inc di
895 loop @Pixel
896
897 popf
898 rcl cx, 1
899 jcxz @Skip3
900
901 lodsb
902 or al, al
903 jz @Odd
904 stosb
905 jmp @Skip3
906 @Odd: inc di
907 @Skip3:
908 pop ax
909 sub di, ax
910 dec dx
911 jnz @Line
912
913 pop di
914
915 pop ax
916 mov al, ah
917 mov cl, 4
918 shl al, cl
919 or ah, al { Mask for next byte }
920 rol ah, 1 { Bit mask for next plane }
921 pop cx { Planes }
922 pop bx
923 inc bl { Still in the same byte? }
924 adc di, 0
925 loop @Plane
926 @End:
927 pop ds
928 end;
929 end;
930
931 procedure PutImage (XPos, YPos, Width, Height: Integer; var BitMap);
932 { Draw an image on the screen (NULL-bytes are NOT ignored) }
933 begin
934 asm
935 push ds
936 push es
937 mov ax, VGA_SEGMENT
938 mov es, ax
939
940 mov ax, YPos
941 mov bx, BYTES_PER_LINE
942 mul bx
943 mov di, XPos
944 mov bx, di
945 shr di, 1
946 shr di, 1
947 add di, ax { DI = (YPos * 80) + XPos / 4 }
948 add di, PageOffset
949
950 lds si, BitMap { Point to bitmap }
951
952 and bl, 3
953 mov cl, bl
954 mov ah, 1
955 shl ah, cl
956 sub bl, 4
957 mov cx, 4 { 4 planes }
958
959 @Plane:
960 push bx
961 push cx { Planes to go }
962 push ax { Mask in AH }
963
964 mov al, MAP_MASK
965 mov dx, SC_INDEX
966 out dx, ax
967
968 cld
969 push di
970 mov bx, Width
971 shr bx, 1
972 shr bx, 1
973 mov ax, BYTES_PER_LINE
974 sub ax, bx { Space before next line }
975 mov dx, Height
976 @Line:
977 mov cx, bx
978 shr cx, 1
979 rep movsw
980 rcl cx, 1
981 rep movsb
982 add di, ax
983 dec dx
984 jnz @Line
985
986 pop di
987
988 pop ax
989 mov al, ah
990 mov cl, 4
991 shl al, cl
992 or ah, al { Mask for next byte }
993 rol ah, 1 { Bit mask for next plane }
994 pop cx { Planes }
995 pop bx
996 inc bl { Still in the same byte? }
997 adc di, 0
998 loop @Plane
999
1000
1001 pop es
1002 pop ds
1003 end;
1004 end;
1005
1006
1007 procedure GetImage (XPos, YPos, Width, Height: Integer; var BitMap);
1008 begin
1009 asm
1010 push ds
1011 push es
1012
1013 mov cx, PageOffset
1014
1015 mov ax, VGA_SEGMENT
1016 mov ds, ax
1017
1018 mov ax, YPos
1019 mov bx, BYTES_PER_LINE
1020 mul bx
1021 mov si, XPos
1022 mov bx, si
1023 shr si, 1
1024 shr si, 1
1025 add si, ax { SI = (YPos * 80) + XPos / 4 }
1026 add si, cx
1027
1028 les di, BitMap { Point to bitmap }
1029
1030 and bl, 3
1031 sub bl, 4
1032 mov cx, 4 { 4 planes }
1033
1034 @Plane:
1035 push bx
1036 push cx { Planes to go }
1037
1038 mov ah, bl
1039 and ah, 3
1040 mov al, READ_MAP
1041 mov dx, GC_INDEX
1042 out dx, ax
1043
1044 cld
1045 push si
1046 mov bx, Width
1047 shr bx, 1
1048 shr bx, 1
1049 mov ax, BYTES_PER_LINE
1050 sub ax, bx { Space before next line }
1051 mov dx, Height
1052 @Line:
1053 mov cx, bx
1054 shr cx, 1
1055 rep movsw
1056 rcl cx, 1
1057 rep movsb
1058 add si, ax
1059 dec dx
1060 jnz @Line
1061
1062 pop si
1063
1064 pop cx { Planes }
1065 pop bx
1066 inc bl { Still in the same byte? }
1067 adc si, 0
1068 loop @Plane
1069
1070
1071 pop es
1072 pop ds
1073 end;
1074 end;
1075
1076 procedure Fill (X, Y, W, H: Integer; Attr: Integer);
1077 { Fills an area on the screen with Attr }
1078 begin
1079 asm
1080 mov ax, VGA_SEGMENT
1081 mov es, ax
1082
1083 cld
1084 mov dx, Y
1085 mov ax, BYTES_PER_LINE
1086 mul dx
1087 mov di, X
1088 push di
1089 shr di, 1
1090 shr di, 1
1091 add di, ax { DI = Y * (width / 4) + X / 4 }
1092 add di, PageOffset
1093 pop cx
1094 and cx, 3 { CX = X mod 4 }
1095
1096 mov ah, 0Fh
1097 shl ah, cl
1098 and ah, 0Fh
1099
1100 mov si, H
1101 or si, si
1102 jz @End { Height 0 }
1103 mov bh, byte ptr Attr
1104 mov dx, W
1105 or dx, dx
1106 jz @End { Width 0 }
1107 add cx, dx
1108 mov dx, SC_INDEX
1109 mov al, MAP_MASK
1110 sub cx, 4
1111 jc @2
1112 test cl, 3h
1113 jnz @0
1114 sub cx, 4
1115 @0: jc @2
1116 out dx, ax
1117
1118 mov al, bh { Attr }
1119 push si { Height }
1120 push di
1121 @4: stosb { Left vertical line }
1122 add di, BYTES_PER_LINE - 1
1123 dec si
1124 jnz @4
1125 pop di
1126 inc di
1127 pop si
1128
1129 push ax
1130 mov ax, 0F00h + MAP_MASK
1131 out dx, ax
1132 pop ax
1133
1134 mov ah, al { Attr }
1135 push cx { Width }
1136 shr cx, 1
1137 shr cx, 1
1138
1139 push si { Height }
1140 push di
1141 @5: push di
1142 push cx
1143 shr cx, 1
1144 rep stosw { Fill middle part }
1145 rcl cx, 1
1146 rep stosb
1147 pop cx
1148 pop di
1149 add di, BYTES_PER_LINE
1150 dec si
1151 jnz @5
1152 pop di
1153 add di, cx { Point to last strip }
1154 pop si { Height }
1155
1156 pop cx { Width }
1157 mov bh, al { Attr }
1158 mov bl, 0Fh { Mask }
1159 jmp @3
1160
1161 @2: mov bl, ah { Begin and end in one single byte }
1162
1163 @3: and cl, 3
1164 mov ah, 0
1165 @1: shl ah, 1
1166 add ah, 1
1167 dec cl
1168 jnz @1
1169
1170 and ah, bl { Use both masks }
1171 mov al, MAP_MASK
1172 out dx, ax
1173 mov al, bh { Attr }
1174 @6: stosb { Draw right vertical line }
1175 add di, BYTES_PER_LINE - 1
1176 dec si
1177 jnz @6
1178 @End:
1179 end;
1180 end;
1181
1182 procedure SetPalette (Color, Red, Green, Blue: Byte);
1183 begin
1184 asm
1185 mov dx, 03C8h { DAC Write Address Register }
1186 mov al, Color
1187 out dx, al
1188 inc dx
1189 mov al, Red
1190 out dx, al
1191 mov al, Green
1192 out dx, al
1193 mov al, Blue
1194 out dx, al
1195 end;
1196 end;
1197
1198 procedure ReadPalette (var NewPalette);
1199 { Read whole palette }
1200 begin
1201 asm
1202 push ds
1203 lds si, NewPalette
1204 mov dx, 3C8h { VGA pel address }
1205 mov al, 0
1206 cli
1207 cld
1208 out dx, al
1209 inc dx
1210 mov cx, 3 * 100h
1211 @1: lodsb
1212 out dx, al
1213 dec cx
1214 jnz @1
1215 sti
1216 pop ds
1217
1218{ push es
1219 push bp
1220 mov ax, 1012h
1221 xor bx, bx
1222 mov cx, 256
1223 les dx, NewPalette
1224 int 10h
1225 pop bp
1226 pop es }
1227 end;
1228 end;
1229
1230 procedure ClearPalette; assembler;
1231 asm
1232 cli
1233 mov dx, 3C8h { VGA pel address }
1234 mov al, 0
1235 out dx, al
1236 inc dx
1237 mov cx, 3 * 100h
1238 @1: out dx, al
1239 dec cx
1240 jnz @1
1241 sti
1242 end;
1243
1244
1245 function CurrentPage: Integer;
1246 begin
1247 CurrentPage := Page;
1248 end;
1249
1250 function GetPageOffset: Word;
1251 begin
1252 GetPageOffset := PageOffset;
1253 end;
1254
1255 procedure ResetStack;
1256 begin
1257 Stack[0] := PAGE_0 + PAGE_SIZE + SAFE;
1258 Stack[1] := PAGE_1 + PAGE_SIZE + SAFE;
1259 end;
1260
1261 function PushBackGr (X, Y, W, H: Integer): Word;
1262 { Save background (X mod 4 = 0, W mod 4 = 0) }
1263 var
1264 StackPointer: Word;
1265 begin
1266 PushBackGr := 0;
1267 if not ((Y + H >= 0) and (Y < 200)) then
1268 Exit;
1269 StackPointer := Stack [Page];
1270 asm
1271 mov bx, PageOffset
1272 mov di, StackPointer
1273 push ds
1274 push es
1275
1276 mov ax, VGA_SEGMENT
1277 mov ds, ax
1278 mov es, ax
1279
1280 cld
1281 mov dx, SC_INDEX
1282 mov ax, 0100h + MAP_MASK
1283 out dx, ax
1284 mov ax, X
1285 mov [di], ax
1286 mov ax, 0200h + MAP_MASK
1287 out dx, ax
1288 mov ax, Y
1289 mov [di], ax
1290 mov ax, 0400h + MAP_MASK
1291 out dx, ax
1292 mov ax, W
1293 mov [di], ax
1294 mov ax, 0800h + MAP_MASK
1295 out dx, ax
1296 mov ax, H
1297 stosw
1298 mov al, 'M'
1299 stosb
1300
1301 mov dx, GC_INDEX
1302 mov al, GRAPHICS_MODE
1303 out dx, al
1304 inc dx
1305 in al, dx
1306 push ax
1307 mov al, 41h
1308 out dx, al
1309
1310 mov dx, SC_INDEX
1311 mov ax, 0F00h + MAP_MASK
1312 out dx, ax
1313
1314 mov ax, READ_MAP
1315 mov dx, GC_INDEX
1316 out dx, ax
1317
1318 mov dx, Y
1319 mov ax, BYTES_PER_LINE
1320 mul dx
1321 mov si, X
1322 shr si, 1
1323 shr si, 1
1324 add si, ax
1325 add si, bx
1326
1327 mov cx, W
1328 shr cx, 1
1329 shr cx, 1
1330
1331 mov bx, H
1332
1333 @1: push cx
1334 rep
1335 movsb { copy 4 pixels }
1336 pop cx
1337 add si, BYTES_PER_LINE
1338 sub si, cx
1339 dec bx
1340 jnz @1
1341
1342 mov dx, GC_INDEX
1343 pop ax
1344 mov ah, al
1345 mov al, GRAPHICS_MODE
1346 out dx, ax
1347
1348 pop es
1349 pop ds
1350 end;
1351 PushBackGr := Stack [Page];
1352 Inc (Stack [Page], W * H + 8);
1353 end;
1354
1355 procedure PopBackGr (Address: Word);
1356 var
1357 X, Y, W, H: Integer;
1358 begin
1359 if Address = 0 then
1360 Exit;
1361 asm
1362 mov bx, PageOffset
1363 mov si, Address
1364
1365 push ds
1366 push es
1367
1368 mov ax, VGA_SEGMENT
1369 mov ds, ax
1370 mov es, ax
1371
1372 cld
1373 mov dx, GC_INDEX
1374 mov ax, 0000h + READ_MAP
1375 out dx, ax
1376 mov ax, [si]
1377 mov X, ax
1378 mov ax, 0100h + READ_MAP
1379 out dx, ax
1380 mov ax, [si]
1381 mov Y, ax
1382 mov ax, 0200h + READ_MAP
1383 out dx, ax
1384 mov ax, [si]
1385 mov W, ax
1386 mov ax, 0300h + READ_MAP
1387 out dx, ax
1388 lodsw
1389 mov H, ax
1390 lodsb
1391 cmp al, 'M'
1392 jz @@1
1393{$IFDEF DEBUG}
1394 int 3
1395{$ENDIF}
1396 jmp @End
1397 @@1:
1398 mov dx, GC_INDEX
1399 mov al, GRAPHICS_MODE
1400 out dx, al
1401 inc dx
1402 in al, dx
1403 push ax
1404 mov al, 41h
1405 out dx, al
1406
1407 mov dx, SC_INDEX
1408 mov ax, 0F00h + MAP_MASK
1409 out dx, ax
1410
1411 mov ax, READ_MAP
1412 mov dx, GC_INDEX
1413 out dx, ax
1414
1415 mov dx, Y
1416 mov ax, BYTES_PER_LINE
1417 mul dx
1418 mov di, X
1419 shr di, 1
1420 shr di, 1
1421 add di, ax
1422 add di, bx
1423
1424 mov cx, W
1425 shr cx, 1
1426 shr cx, 1
1427
1428 mov bx, H
1429
1430 @1: push cx
1431 rep
1432 movsb { copy 4 pixels }
1433 pop cx
1434 add di, BYTES_PER_LINE
1435 sub di, cx
1436 dec bx
1437 jnz @1
1438
1439 mov dx, GC_INDEX
1440 pop ax
1441 mov ah, al
1442 mov al, GRAPHICS_MODE
1443 out dx, ax
1444
1445 @end: pop es
1446 pop ds
1447 end;
1448 end;
1449
1450 procedure DrawBitmap (X, Y: Integer; var BitMap; Attr: Byte);
1451 { Bitmap starts with size W, H (Byte) }
1452 var
1453 W, H, PageOffset: Integer;
1454 begin
1455 PageOffset := GetPageOffset;
1456 asm
1457 push es
1458 push ds
1459
1460 lds si, BitMap
1461 mov ah, 0
1462 cld
1463 lodsb
1464 mov W, ax
1465 lodsb
1466 mov H, ax
1467 mov ax, VGA_SEGMENT
1468 mov es, ax
1469
1470 mov bl, 0
1471 mov cx, H
1472 mov dx, Y
1473 @1: push cx
1474 mov cx, X
1475 mov di, W
1476 @2: push cx
1477 push dx
1478 or bl, bl
1479 jnz @3
1480 lodsb
1481 mov bh, al
1482 mov bl, 8
1483 @3: dec bl
1484 shr bh, 1
1485 jnc @4
1486
1487 push si
1488 push di
1489 push bx
1490 mov al, Attr
1491
1492 @PutPixel:
1493 { CX = X, DX = Y, AL = Attr }
1494 push ax
1495 mov ax, BYTES_PER_LINE
1496 mul dx
1497 push cx
1498 shr cx, 1
1499 shr cx, 1
1500 add ax, cx
1501 mov di, ax
1502 add di, PageOffset
1503 pop cx
1504 and cl, 3
1505 mov ah, 1
1506 shl ah, cl
1507 mov al, MAP_MASK
1508 mov dx, SC_INDEX
1509 out dx, ax
1510 pop ax
1511 stosb
1512
1513 pop bx
1514 pop di
1515 pop si
1516
1517 @4:
1518 pop dx
1519 pop cx
1520 inc cx
1521 dec di
1522 jnz @2
1523
1524 inc dx
1525 pop cx
1526 dec cx
1527 jnz @1
1528 pop ds
1529 pop es
1530 end;
1531 end;
1532
1533begin
1534 OldScreenMode := GetMode;
1535end.