├── BIN2SRC ├── BIN2BSV.PAS └── BIN2SRC.PAS ├── LICENSE ├── README.md ├── RM ├── BGIEDIT.PAS ├── BGIGADGE.PAS ├── BGIIMAGE.PAS ├── BGIMISC.PAS ├── BGIMOUSE.PAS ├── BGIPAL.PAS ├── BGIREQ.PAS ├── BGITEXT.PAS ├── BIGEDIT.PAS ├── BITS.PAS ├── CORE.PAS ├── DEF2RAW.PAS ├── DRIVERS.PAS ├── FORMAT.PAS ├── KEYS.PAS ├── MESSAGES.PAS ├── PANEL.PAS ├── RM.INC ├── RM.PAS ├── RML16.OBJ ├── RML16.XGF ├── RML256.OBJ ├── RML256.XGF ├── RMLOGO.BMP ├── RMSTRG.PAS ├── RMTITLE.PAS ├── RRES.PAS ├── RWBMP.PAS ├── RWCEL.PAS ├── RWCUSTOM.PAS ├── RWICO.PAS ├── RWPCX.PAS ├── RWXGF.PAS ├── SCREEN.PAS ├── SVGA16.BGI ├── SVGA16.OBJ ├── SVGA256.BGI ├── SVGA256.OBJ ├── TOOLS.PAS ├── VARS.PAS ├── WCON.PAS ├── WDEF.PAS ├── WMASK.PAS ├── WPRF.PAS ├── XGF2SRC.PAS └── XGRAPH.PAS ├── RMCLIP ├── BGIEDIT.PAS ├── BGIGADGE.PAS ├── BGIIMAGE.PAS ├── BGIMISC.PAS ├── BGIMOUSE.PAS ├── BGIPAL.PAS ├── BGITEXT.PAS ├── BITS.PAS ├── KEYS.PAS ├── PANEL.PAS ├── PARSE.PAS ├── RKEY.PAS ├── RLIST.PAS ├── RMCLIP.PAS ├── RWBMP.PAS ├── RWPAL.PAS ├── RWPCX.PAS ├── RWRAW.PAS ├── SCREEN.PAS ├── SVGA16.BGI ├── SVGA16.OBJ ├── SVGA256.BGI ├── SVGA256.OBJ ├── VARS.PAS ├── WPRF.PAS ├── WXGF.PAS └── XGRAPH.PAS └── RP ├── PCX2RAW.PAS ├── PCX2XGF.PAS ├── RAW2DEF.PAS ├── RAW2PRF.PAS ├── RAW2XGF.PAS ├── RKEY.PAS ├── RP.PAS ├── VARS.PAS └── WXGF.PAS /BIN2SRC/BIN2BSV.PAS: -------------------------------------------------------------------------------- 1 | (* Data Meaning 2 | 'BYTE Magic number (always 0xFD, 253) 3 | 'INT Segment. Set to 0x9999 by modern versions. 4 | 'INT Offset is always 0 5 | 'INT Length, the number of bytes 6 | 7 | Article: Q34407 8 | Product(s): See article 9 | Version(s): 3.00 4.00 4.00b 4.50 10 | Operating System(s): MS-DOS 11 | Keyword(s): ENDUSER | B_BasicCom B_GWBasicI | mspl13_basic 12 | Last Modified: 9-JAN-1991 13 | 14 | A file saved with the BSAVE statement has a 7-byte header with the 15 | following hexadecimal format: 16 | 17 | ww xx xx yy yy zz zz 18 | 19 | ww: A signature byte equal to 253, which tells DOS and other 20 | programs that this is a BASIC BSAVE/BLOAD format file. 21 | xx xx: The segment address from the last BSAVE. 22 | yy yy: The offset address from the last BSAVE. 23 | zz zz: The number of bytes BSAVEd. 24 | 25 | This information applies to Microsoft QuickBASIC versions 3.00, 4.00, 26 | 4.00b, and 4.50 for MS-DOS; to Microsoft BASIC Compiler versions 6.00 27 | and 6.00b for MS-DOS; and to Microsoft BASIC Professional Development 28 | System (PDS) versions 7.00 and 7.10 for MS-DOS. 29 | 30 | This information is provided as is. The BSAVE format is not guaranteed 31 | to be the same in a future release. 32 | 33 | Microsoft GW-BASIC Interpreter (versions 3.20, 3.22, and 3.23) uses 34 | the same 7-byte header string, and also repeats the 7-byte string, 35 | appending it after the final data byte. BASICA (provided in IBM or 36 | Compaq ROM on some computer models) does not repeat the 7-byte string 37 | at the end. GW-BASIC and BASICA both terminate the file with ASCII 26, 38 | also known as a CTRL+Z character (hex 1A). QuickBASIC and Microsoft 39 | BASIC Compiler don't append CTRL+Z or repeat the 7-byte string at the 40 | end. 41 | 42 | To determine whether a file was BSAVEd by GW-BASIC, BASICA, or 43 | QuickBASIC, compare the length of the memory saved against the file 44 | length. The difference is 15 bytes in GW-BASIC, 7 bytes in QuickBASIC, 45 | and 8 bytes in BASICA. 46 | 47 | Despite the slight format differences, files BSAVEd under any of the 48 | three above BASIC dialects correctly BLOAD into each other BASIC. 49 | *) 50 | 51 | Program BIN2BSV; 52 | 53 | const 54 | ProgramName = 'Bin2Bsv 1.0'; 55 | CopyRight = '(c) Copyright 2022 By RetroNick. All Rights Reserved'; 56 | GitHub1 = 'Get source and latest version from github:'; 57 | GitHub2 = 'https://github.com/RetroNick2020'; 58 | 59 | MaxBSaveSize = 32767; 60 | type 61 | BsvRec = Record 62 | Magic : Byte; 63 | Seg : Word; 64 | Off : Word; 65 | Length : Word; 66 | end; 67 | 68 | Var 69 | InFileMemPtr : Pointer; 70 | InFileSize : Word; 71 | 72 | 73 | (* we could allocate less memory - but this just a small app - 32Kb is no big deal *) 74 | Procedure GetTheMemory; 75 | begin 76 | GetMem(InFileMemPtr,MaxBsaveSize); 77 | if InFileMemPtr = NIL then 78 | begin 79 | Writeln('Failed to Allocate Enough Memeory, we need ',MaxBSaveSize,' bytes!'); 80 | end; 81 | end; 82 | 83 | Procedure FreeTheMemory; 84 | begin 85 | if InFileMemPtr<>NIL then 86 | begin 87 | Freemem(InFileMemPtr,MaxBsaveSize); 88 | end; 89 | end; 90 | 91 | 92 | Procedure FailAndCleanUp; 93 | begin 94 | FreeTheMemory; 95 | writeln('Looks like something went wrong - not sure what to say.'); 96 | halt; 97 | end; 98 | 99 | Procedure CheckSize(filename : string); 100 | var 101 | F : File; 102 | begin 103 | Assign(F,filename); 104 | {$I-} 105 | Reset(F,1); 106 | if FileSize(F) > 32767 then 107 | begin 108 | writeln('Source file too big. Must be ',MaxBSaveSize,' bytes or less!'); 109 | Close(F); 110 | FreeTheMemory; 111 | Halt; 112 | end; 113 | Close(f); 114 | {$I+} 115 | if IOResult <> 0 then 116 | begin 117 | FailAndCleanUp; 118 | end; 119 | end; 120 | 121 | Procedure ReadFile(filename : string); 122 | var 123 | F : File; 124 | RSize : Word; 125 | begin 126 | Assign(F,filename); 127 | {$I-} 128 | Reset(F,1); 129 | BlockRead(F,InFileMemPtr^,MaxBSaveSize,RSize); 130 | close(F); 131 | {$I+} 132 | if IOResult <> 0 then 133 | begin 134 | FailAndCleanUp; 135 | end; 136 | InFileSize:=RSize; 137 | end; 138 | 139 | Procedure WriteFile(filename : string); 140 | var 141 | F : File; 142 | WSize : Word; 143 | Bsv :BsvRec; 144 | begin 145 | Bsv.Magic:=$FD; (* 253 *) 146 | Bsv.Seg:=$9999; 147 | Bsv.Off:=$0; 148 | Bsv.Length:=InFileSize; 149 | Assign(F,filename); 150 | {$I-} 151 | Rewrite(F,1); 152 | BlockWrite(F,Bsv,sizeof(Bsv)); 153 | BlockWrite(F,InFileMemPtr^,InFileSize,WSize); 154 | BlockWrite(F,Bsv,sizeof(Bsv)); 155 | close(F); 156 | {$I+} 157 | if IOResult <> 0 then 158 | begin 159 | FailAndCleanUp; 160 | end; 161 | end; 162 | 163 | Procedure PrintHelp; 164 | begin 165 | writeln(ProgramName); 166 | writeln(Copyright); 167 | writeln; 168 | writeln(GitHub1); 169 | writeln(GitHub2); 170 | writeln; 171 | 172 | writeln('Usage: Bin2Bsv '); 173 | writeln; 174 | writeln(' eg. BIN2BSV ASMCODE.COM ASMCODE.BSV'); 175 | end; 176 | 177 | var 178 | InFile,OutFile : string; 179 | begin 180 | if ParamCount < 2 then 181 | begin 182 | printHelp; 183 | halt; 184 | end; 185 | 186 | InFile:=ParamStr(1); 187 | OutFile:=ParamStr(2); 188 | CheckSize(InFile); 189 | GetTheMemory; 190 | ReadFile(InFile); 191 | WriteFile(OutFile); 192 | FreeTheMemory; 193 | end. -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 RetroNick's Youtube Channel 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # raster-master-dos 2 | Raster Master & Utilities for Dos 3 | 4 | A Sprite/Icon editor that generates code for Turbo Pascal/Turbo C and QuickBASIC/QuickC,TEGL and Fastgraph. A command line converter (Rasport) and an image cliping utlility (Raster Clip). Plus a command binary to source code converter (Bin2Src) and binary to bsave tool (BIN2BSV) for GWBASIC programmers. 5 | 6 | Note: There is a Windows version with many new features 7 | https://github.com/RetroNick2020/raster-master 8 | 9 | -------------------------------------------------------------------------------- /RM/BGIEDIT.PAS: -------------------------------------------------------------------------------- 1 | Unit bgiEdit; 2 | Interface 3 | 4 | Procedure EditString(x,y,visibleColumns: Integer;Var cursorState: integer;BackColor, 5 | forColor,curColor, mouseState : Integer;Var msg : String); 6 | Implementation 7 | uses dos,crt,graph,keys,bgiMouse; 8 | 9 | Procedure EditString(x,y,visibleColumns: Integer;Var cursorState: integer;BackColor, 10 | forColor,curColor, mouseState : Integer;Var msg : String); 11 | 12 | Const 13 | FWidth = 8; 14 | FHeight = 9; 15 | flash : Boolean = True; 16 | var 17 | myKey : Word; 18 | tempString : String; 19 | offset : Integer; 20 | Pos : Integer; 21 | originalString : String; 22 | 23 | Procedure ShowCursor; 24 | begin 25 | SetFillStyle(SolidFill,curColor); 26 | Case cursorState of 0:begin 27 | Bar(x+(pos*FWidth)-FWidth,y,x+(pos*FWidth)-2,y+FHeight); 28 | if length(msg) >0 then 29 | begin 30 | Setcolor(backColor); 31 | OutTextXY(x+(pos*FWidth)-FWidth,y,msg[Pos+offset]); 32 | end; 33 | 34 | end; 35 | 1:begin 36 | Bar(x+(pos*FWidth)-FWidth,y+FHeight-1, 37 | x+(pos*FWidth)-2,y+FHeight); 38 | (* 39 | if length(msg) >0 then 40 | begin 41 | Setcolor(backColor); 42 | OutTextXY(x+(pos*FWidth)-FWidth,y,msg[Pos+offset]); 43 | end; 44 | *) 45 | end; 46 | end; 47 | 48 | end; 49 | 50 | Procedure HideCursor; 51 | begin 52 | SetFillStyle(SolidFill,backColor); 53 | Case cursorState of 0:begin 54 | Bar(x+(pos*FWidth)-FWidth, 55 | y,x+(pos*FWidth)-2, 56 | y+FHeight); 57 | Setcolor(forColor); 58 | OuttextXY(x+(pos*FWidth)-FWidth,y, 59 | msg[Pos+offset]); 60 | end; 61 | 1:begin 62 | Bar(x+(pos*FWidth)-FWidth, 63 | y+FHeight-1, 64 | x+(pos*FWidth)-2, 65 | y+FHeight); 66 | end; 67 | end; 68 | end; 69 | 70 | Procedure ClearEditBox; 71 | begin 72 | SetFillStyle(SolidFill,BackColor); 73 | Bar(x,y,x+(visibleColumns*FWidth)-2,y+FHeight); 74 | end; 75 | 76 | Procedure HomeKeyAction; 77 | begin 78 | if (pos+offset)<>1 then 79 | begin 80 | pos:=1; 81 | offset:=0; 82 | tempstring:=copy(msg,offset+1,visiblecolumns); 83 | 84 | if mouseState=1 then MouseHide; 85 | clearEditBox; 86 | Setcolor(forColor); 87 | OuttextXY(x,y,tempstring); 88 | showcursor; 89 | if mouseState=1 then MouseShow; 90 | 91 | end; 92 | end; 93 | 94 | Procedure EndKeyAction; 95 | begin 96 | if (pos+offset) <> length(msg) then 97 | begin 98 | if length(msg) > visibleColumns then 99 | begin 100 | pos:=visibleColumns; 101 | offset:=length(msg)-pos; 102 | end 103 | else 104 | begin 105 | pos:=length(msg); 106 | offset:=0; 107 | end; 108 | tempstring:=copy(msg,offset+1,visiblecolumns); 109 | 110 | if mouseState=1 then MouseHide; 111 | clearEditBox; 112 | Setcolor(forColor); 113 | OuttextXY(x,y,tempstring); 114 | showcursor; 115 | if mouseState=1 then MouseShow; 116 | end; 117 | end; 118 | 119 | Procedure LeftKeyAction; 120 | begin 121 | if (pos > 1) then 122 | begin 123 | if mouseState=1 then MouseHide; 124 | hidecursor; 125 | dec(pos); 126 | showcursor; 127 | if mouseState=1 then MouseShow; 128 | end 129 | else if ((pos=1) AND (offset>0)) then 130 | begin 131 | dec(offset); 132 | tempstring:=copy(msg,pos+offset,visibleColumns); 133 | if mouseState=1 then MouseHide; 134 | cleareditbox; 135 | Setcolor(forColor); 136 | OuttextXY(x,y,tempstring); 137 | showcursor; 138 | if mouseState=1 then MouseShow; 139 | end; 140 | end; 141 | 142 | Procedure RightKeyAction; 143 | begin 144 | if Length(msg)<>0 then 145 | begin 146 | if (pos < visibleColumns) then 147 | begin 148 | if length(msg) > (pos+offset) then 149 | begin 150 | if mouseState=1 then MouseHide; 151 | hidecursor; 152 | inc(pos); 153 | showcursor; 154 | if mouseState=1 then MouseShow; 155 | end; 156 | end 157 | else if ((pos+offset)< Length(msg)) then 158 | begin 159 | inc(offset); 160 | tempstring:=copy(msg,offset+1,visiblecolumns); 161 | if mouseState=1 then MouseHide; 162 | clearEditBox; 163 | Setcolor(forColor); 164 | OutTextXY(x,y,tempstring); 165 | showcursor; 166 | if mouseState=1 then MouseShow; 167 | end; 168 | end; 169 | end; 170 | 171 | Procedure DelKeyAction; 172 | begin 173 | if length(msg)<>0 then 174 | begin 175 | delete(msg,pos+offset,1); 176 | if (pos+offset) > length(msg) then 177 | begin 178 | if offset > 0 then 179 | begin 180 | dec(offset); 181 | end 182 | else if pos > 1 then 183 | begin 184 | dec(pos); 185 | end; 186 | end; 187 | if mouseState=1 then MouseHide; 188 | clearEditBox; 189 | if length(msg)<>0 then 190 | begin 191 | tempstring:=copy(msg,offset+1,visiblecolumns); 192 | Setcolor(forColor); 193 | OuttextXY(x,y,tempstring); 194 | showcursor; 195 | end; 196 | if mouseState=1 then MouseShow; 197 | end; 198 | end; 199 | 200 | Procedure BackKeyAction; 201 | begin 202 | if length(msg)>1 then 203 | begin 204 | delete(msg,pos+offset-1,1); 205 | if pos > 1 then 206 | begin 207 | dec(pos); 208 | end 209 | else if offset>0 then 210 | begin 211 | dec(offset); 212 | end; 213 | tempstring:=copy(msg,offset+1,visiblecolumns); 214 | if mouseState=1 then MouseHide; 215 | clearEditBox; 216 | Setcolor(forColor); 217 | OuttextXY(x,y,tempstring); 218 | showcursor; 219 | if mouseState=1 then MouseShow; 220 | end; 221 | end; 222 | 223 | Procedure CharKeyAction; 224 | begin 225 | if length(msg)<>0 then 226 | begin 227 | if ((pos+offset)<>length(msg)) AND (cursorState=0) then 228 | begin 229 | msg[pos+offset]:=chr(mykey); 230 | end 231 | else 232 | begin 233 | insert(chr(mykey),msg,pos+offset); 234 | end; 235 | end 236 | else 237 | begin 238 | insert(chr(mykey)+#32,msg,pos+offset); 239 | end; 240 | if (pos ppos) then 302 | begin 303 | if (ppos > visiblecolumns) or (ppos<0) then exit; 304 | if ppos>length(msg) then ppos:=length(msg); 305 | MouseHide; 306 | hidecursor; 307 | pos:=ppos; 308 | showcursor; 309 | MouseShow; 310 | end; 311 | Repeat Until LKey=False; 312 | end; 313 | 314 | Function IsInEditBox : Boolean; 315 | Var 316 | my,mx,st : Integer; 317 | begin 318 | IsInEditBox:=False; 319 | MouseGetStatus(st,my,mx); 320 | if (mx>x-2) and (my>y-2) and (mx 0 then 29 | begin 30 | Setcolor(backColor); 31 | OutTextXY(x+(pos*FWidth)-FWidth,y,msg[Pos+offset]); 32 | end; 33 | 34 | end; 35 | 1:begin 36 | Bar(x+(pos*FWidth)-FWidth,y+FHeight-1, 37 | x+(pos*FWidth)-2,y+FHeight); 38 | (* 39 | if length(msg) >0 then 40 | begin 41 | Setcolor(backColor); 42 | OutTextXY(x+(pos*FWidth)-FWidth,y,msg[Pos+offset]); 43 | end; 44 | *) 45 | end; 46 | end; 47 | 48 | end; 49 | 50 | Procedure HideCursor; 51 | begin 52 | SetFillStyle(SolidFill,backColor); 53 | Case cursorState of 0:begin 54 | Bar(x+(pos*FWidth)-FWidth, 55 | y,x+(pos*FWidth)-2, 56 | y+FHeight); 57 | Setcolor(forColor); 58 | OuttextXY(x+(pos*FWidth)-FWidth,y, 59 | msg[Pos+offset]); 60 | end; 61 | 1:begin 62 | Bar(x+(pos*FWidth)-FWidth, 63 | y+FHeight-1, 64 | x+(pos*FWidth)-2, 65 | y+FHeight); 66 | end; 67 | end; 68 | end; 69 | 70 | Procedure ClearEditBox; 71 | begin 72 | SetFillStyle(SolidFill,BackColor); 73 | Bar(x,y,x+(visibleColumns*FWidth)-2,y+FHeight); 74 | end; 75 | 76 | Procedure HomeKeyAction; 77 | begin 78 | if (pos+offset)<>1 then 79 | begin 80 | pos:=1; 81 | offset:=0; 82 | tempstring:=copy(msg,offset+1,visiblecolumns); 83 | 84 | if mouseState=1 then MouseHide; 85 | clearEditBox; 86 | Setcolor(forColor); 87 | OuttextXY(x,y,tempstring); 88 | showcursor; 89 | if mouseState=1 then MouseShow; 90 | 91 | end; 92 | end; 93 | 94 | Procedure EndKeyAction; 95 | begin 96 | if (pos+offset) <> length(msg) then 97 | begin 98 | if length(msg) > visibleColumns then 99 | begin 100 | pos:=visibleColumns; 101 | offset:=length(msg)-pos; 102 | end 103 | else 104 | begin 105 | pos:=length(msg); 106 | offset:=0; 107 | end; 108 | tempstring:=copy(msg,offset+1,visiblecolumns); 109 | 110 | if mouseState=1 then MouseHide; 111 | clearEditBox; 112 | Setcolor(forColor); 113 | OuttextXY(x,y,tempstring); 114 | showcursor; 115 | if mouseState=1 then MouseShow; 116 | end; 117 | end; 118 | 119 | Procedure LeftKeyAction; 120 | begin 121 | if (pos > 1) then 122 | begin 123 | if mouseState=1 then MouseHide; 124 | hidecursor; 125 | dec(pos); 126 | showcursor; 127 | if mouseState=1 then MouseShow; 128 | end 129 | else if ((pos=1) AND (offset>0)) then 130 | begin 131 | dec(offset); 132 | tempstring:=copy(msg,pos+offset,visibleColumns); 133 | if mouseState=1 then MouseHide; 134 | cleareditbox; 135 | Setcolor(forColor); 136 | OuttextXY(x,y,tempstring); 137 | showcursor; 138 | if mouseState=1 then MouseShow; 139 | end; 140 | end; 141 | 142 | Procedure RightKeyAction; 143 | begin 144 | if Length(msg)<>0 then 145 | begin 146 | if (pos < visibleColumns) then 147 | begin 148 | if length(msg) > (pos+offset) then 149 | begin 150 | if mouseState=1 then MouseHide; 151 | hidecursor; 152 | inc(pos); 153 | showcursor; 154 | if mouseState=1 then MouseShow; 155 | end; 156 | end 157 | else if ((pos+offset)< Length(msg)) then 158 | begin 159 | inc(offset); 160 | tempstring:=copy(msg,offset+1,visiblecolumns); 161 | if mouseState=1 then MouseHide; 162 | clearEditBox; 163 | Setcolor(forColor); 164 | OutTextXY(x,y,tempstring); 165 | showcursor; 166 | if mouseState=1 then MouseShow; 167 | end; 168 | end; 169 | end; 170 | 171 | Procedure DelKeyAction; 172 | begin 173 | if length(msg)<>0 then 174 | begin 175 | delete(msg,pos+offset,1); 176 | if (pos+offset) > length(msg) then 177 | begin 178 | if offset > 0 then 179 | begin 180 | dec(offset); 181 | end 182 | else if pos > 1 then 183 | begin 184 | dec(pos); 185 | end; 186 | end; 187 | if mouseState=1 then MouseHide; 188 | clearEditBox; 189 | if length(msg)<>0 then 190 | begin 191 | tempstring:=copy(msg,offset+1,visiblecolumns); 192 | Setcolor(forColor); 193 | OuttextXY(x,y,tempstring); 194 | showcursor; 195 | end; 196 | if mouseState=1 then MouseShow; 197 | end; 198 | end; 199 | 200 | Procedure BackKeyAction; 201 | begin 202 | if length(msg)>1 then 203 | begin 204 | delete(msg,pos+offset-1,1); 205 | if pos > 1 then 206 | begin 207 | dec(pos); 208 | end 209 | else if offset>0 then 210 | begin 211 | dec(offset); 212 | end; 213 | tempstring:=copy(msg,offset+1,visiblecolumns); 214 | if mouseState=1 then MouseHide; 215 | clearEditBox; 216 | Setcolor(forColor); 217 | OuttextXY(x,y,tempstring); 218 | showcursor; 219 | if mouseState=1 then MouseShow; 220 | end; 221 | end; 222 | 223 | Procedure CharKeyAction; 224 | begin 225 | if length(msg)<>0 then 226 | begin 227 | if ((pos+offset)<>length(msg)) AND (cursorState=0) then 228 | begin 229 | msg[pos+offset]:=chr(mykey); 230 | end 231 | else 232 | begin 233 | insert(chr(mykey),msg,pos+offset); 234 | end; 235 | end 236 | else 237 | begin 238 | insert(chr(mykey)+#32,msg,pos+offset); 239 | end; 240 | if (pos ppos) then 302 | begin 303 | if (ppos > visiblecolumns) or (ppos<0) then exit; 304 | if ppos>length(msg) then ppos:=length(msg); 305 | MouseHide; 306 | hidecursor; 307 | pos:=ppos; 308 | showcursor; 309 | MouseShow; 310 | end; 311 | Repeat Until LKey=False; 312 | end; 313 | 314 | Function IsInEditBox : Boolean; 315 | Var 316 | my,mx,st : Integer; 317 | begin 318 | IsInEditBox:=False; 319 | MouseGetStatus(st,my,mx); 320 | if (mx>x-2) and (my>y-2) and (mx 0; 15 | End; 16 | 17 | Procedure SetBit(Position, Value : Byte; Var Changebyte : Byte); 18 | Var 19 | Bt : Byte; 20 | Begin 21 | Bt :=$01; 22 | Bt :=Bt Shl Position; 23 | If Value = 1 then 24 | Changebyte :=Changebyte Or Bt 25 | Else 26 | Begin 27 | Bt :=Bt Xor $FF; 28 | Changebyte :=Changebyte And Bt; 29 | End; 30 | End; 31 | 32 | begin 33 | end. -------------------------------------------------------------------------------- /RM/CORE.PAS: -------------------------------------------------------------------------------- 1 | Unit Core; 2 | 3 | Interface 4 | 5 | Function MostColors : Word; 6 | Procedure Fill(xx,yy: Word); 7 | Procedure ReduceTo16; 8 | Procedure DrawFullIconImage(x,y,x2,y2 : word); 9 | 10 | Implementation 11 | Uses Vars,graph; 12 | 13 | 14 | Procedure ReduceTo16; 15 | Var 16 | i,j : Word; 17 | T : byte; 18 | begin 19 | For i:=1 to 100 do 20 | begin 21 | For j:=1 to 100 do 22 | begin 23 | T:=IconImage[i,j] SHL 4; 24 | IconImage[i,j]:=T SHR 4; 25 | end; 26 | end; 27 | end; 28 | 29 | 30 | Function MostColors : Word; 31 | Var 32 | colorList : Array[0..255] of Word; 33 | oc,mc,i,j : Word; 34 | 35 | begin 36 | FillChar(colorList,sizeof(colorList),0); 37 | For i:=1 to 100 do 38 | begin 39 | For j:=1 to 100 do 40 | begin 41 | Inc(colorList[IconImage[i,j]]); 42 | end; 43 | end; 44 | mc:=0; 45 | oc:=0; 46 | for i:=0 to 255 do 47 | begin 48 | if colorList[i]>mc then 49 | begin 50 | mc:=colorList[i]; 51 | oc:=i; 52 | end; 53 | end; 54 | MostColors:=oc; 55 | 56 | end; 57 | 58 | Procedure Fill(xx,yy: Word); 59 | const 60 | Left =1; 61 | right=2; 62 | up =3; 63 | down =4; 64 | 65 | Type 66 | stype = Array[0..10000] of byte; 67 | stypePtr=^Stype; 68 | Var 69 | StackHolderX : stypePtr; 70 | StackHolderY : stypePtr; 71 | StackHolderPos : stypePtr; 72 | sthnum : word; 73 | pp : Word; 74 | coltofill : Word; 75 | 76 | 77 | Procedure CheckRight; 78 | begin 79 | if xx<100 then 80 | begin 81 | if IconImage[xx+1,yy] = ColTofill then 82 | begin 83 | (* Pplot2(xx+1,yy,false);*) 84 | IconImage[xx+1,yy] :=Ncolor; 85 | inc(sthnum); 86 | StackHolderx^[sthnum]:=xx+1; 87 | StackHoldery^[sthnum]:=yy; 88 | StackHolderpos^[sthnum]:=Right; 89 | end; 90 | end; 91 | end; 92 | 93 | 94 | Procedure CheckLeft; 95 | Begin 96 | if xx >1 then 97 | begin 98 | if IconImage[xx-1,yy] = ColTofill then 99 | begin 100 | (* Pplot2(xx-1,yy,false);*) 101 | IconImage[xx-1,yy]:=Ncolor; 102 | inc(sthnum); 103 | StackHolderx^[sthnum]:=xx-1; 104 | StackHoldery^[sthnum]:=yy; 105 | StackHolderpos^[sthnum]:=left; 106 | end; 107 | end; 108 | end; 109 | 110 | Procedure CheckUp; 111 | begin 112 | if yy>1 then 113 | begin 114 | if IconImage[xx,yy-1] = ColTofill then 115 | begin 116 | (* Pplot2(xx,yy-1,false);*) 117 | IconImage[xx,yy-1]:=Ncolor; 118 | inc(sthnum); 119 | StackHolderx^[sthnum]:=xx; 120 | StackHoldery^[sthnum]:=yy-1; 121 | StackHolderpos^[sthnum]:=up; 122 | end; 123 | end; 124 | 125 | end; 126 | 127 | Procedure CheckDown; 128 | var c : integer; 129 | begin 130 | if yy<100 then 131 | begin 132 | If IconImage[xx,yy+1]=ColTofill then 133 | begin 134 | (* Pplot2(xx,yy+1,false);*) 135 | IconImage[xx,yy+1]:=Ncolor; 136 | inc(sthnum); 137 | StackHolderx^[sthnum]:=xx; 138 | StackHoldery^[sthnum]:=yy+1; 139 | StackHolderpos^[sthnum]:=down; 140 | end; 141 | end; 142 | end; 143 | 144 | Procedure GetColortoFill; 145 | begin 146 | ColToFill:=IconImage[xx,yy]; 147 | end; 148 | 149 | 150 | 151 | Procedure GetNewCord; 152 | begin 153 | if sthnum > 0 then 154 | begin 155 | xx:=StackHolderx^[sthnum]; 156 | yy:=StackHoldery^[sthnum]; 157 | pp:=StackHolderpos^[sthnum]; 158 | dec(sthnum); 159 | end; 160 | end; 161 | 162 | 163 | 164 | 165 | begin 166 | GetMem(StackHolderX,SizeOf(Stype)); 167 | GetMem(StackHolderY,SizeOf(Stype)); 168 | GetMem(StackHolderPos,SizeOf(Stype)); 169 | 170 | 171 | FillChar(StackHolderX^,SizeOf(StackHolderX),0); 172 | FillChar(StackHolderY^,SizeOf(StackHolderY),0); 173 | FillChar(StackHolderPos^,SizeOf(StackHolderPos),0); 174 | 175 | sthnum:=1; 176 | GetColorTofill; 177 | IconImage[xx,yy]:=Ncolor; 178 | Repeat 179 | case pp of 180 | Left: begin 181 | CheckLeft; 182 | CheckDown; 183 | Checkup; 184 | end; 185 | Right:begin 186 | CheckRight; 187 | CheckUp; 188 | CheckDown; 189 | end; 190 | Up: begin 191 | CheckRight; 192 | CheckLeft; 193 | Checkup; 194 | end; 195 | Down: begin 196 | CheckDown; 197 | CheckRight; 198 | CheckLeft; 199 | end; 200 | else 201 | begin 202 | CheckRight; 203 | CheckUP; 204 | CheckDown; 205 | CheckLeft; 206 | end; 207 | end; 208 | GetNewCord; 209 | Until sthnum=0; 210 | FreeMem(StackHolderX,SizeOf(Stype)); 211 | FreeMem(StackHolderY,SizeOf(Stype)); 212 | FreeMem(StackHolderPos,SizeOf(Stype)); 213 | 214 | end; 215 | 216 | Procedure DrawFullIconImage(x,y,x2,y2 : word); 217 | Var 218 | i,j : Word; 219 | Back : Word; 220 | begin 221 | Back:=MostColors; 222 | For i:=x to x2 do 223 | begin 224 | For j:=y to y2 do 225 | begin 226 | if IconImage[i+xoff,j+yoff] <> Back then 227 | begin 228 | SetFillStyle(SolidFill,IconImage[i+xoff,j+yoff]); 229 | Bar(GridBox_x+(i-1)*CellW+1,GridBox_y+(j-1)*CellH+1, 230 | GridBox_x+(i-1)*CellW+CellW-1+GridLine,GridBox_y+(j-1)*CellH+CellH-1+GridLine); 231 | end; 232 | end; 233 | end; 234 | end; 235 | 236 | 237 | begin 238 | end. -------------------------------------------------------------------------------- /RM/DEF2RAW.PAS: -------------------------------------------------------------------------------- 1 | {$M 1024,0,0} 2 | Program DEF2RAW; 3 | Var 4 | FT : Text; 5 | FB : File; 6 | DefFile : String; 7 | RawFile : String; 8 | Image : Array[1..100] of String[100]; 9 | Count : Word; 10 | Width,Height : Word; 11 | T : Byte; 12 | i,j : Word; 13 | tempStr : String; 14 | Error : Word; 15 | begin 16 | FillChar(Image,SizeOf(Image),'2'); 17 | RawFile:='RM$$.RAW'; 18 | DefFile:=ParamStr(1); 19 | {$I-} 20 | writeln(deffile); 21 | Assign(FT,DEFFile); 22 | Reset(FT); 23 | Error:=IORESULT; 24 | If Error<>0 then 25 | begin 26 | HALT(Error); 27 | end; 28 | Count:=0; 29 | While Not EOF(FT) AND (Count <100) Do 30 | begin 31 | Inc(Count); 32 | Readln(FT,Image[Count]); 33 | end; 34 | Close(FT); 35 | Height:=Count; 36 | Width:=0; 37 | For i:=1 to Height do 38 | begin 39 | if Length(Image[i]) > Width then Width:=Length(image[i]); 40 | end; 41 | Count:=0; 42 | 43 | if Height > 100 then Height:=100; 44 | if Width > 100 then Width:=100; 45 | Assign(FB,RawFile); 46 | Rewrite(FB,1); 47 | BlockWrite(FB,Width,2); 48 | BlockWrite(FB,Height,2); 49 | BlockWrite(FB,Count,2); 50 | t:=0; 51 | For j:=1 to Height do 52 | begin 53 | TempStr:=Image[j]; 54 | For i:=1 to Width do 55 | begin 56 | t:=ORD(UPCASE(TempStr[i])); 57 | Case t of 48: t:=0; 58 | 49..57: Dec(t,48); 59 | 65..70: Dec(t,55); 60 | end; 61 | TempStr[i]:=CHR(t); 62 | end; 63 | BlockWrite(FB,TempStr[1],Width); 64 | end; 65 | Close(FB); 66 | Error:=IORESULT; 67 | {$I+} 68 | end. -------------------------------------------------------------------------------- /RM/DRIVERS.PAS: -------------------------------------------------------------------------------- 1 | Unit Drivers; 2 | 3 | Interface 4 | 5 | Procedure EgaVgaDriverProc; 6 | 7 | procedure SVga256Proc; 8 | 9 | Implementation 10 | 11 | procedure EgaVgaDriverProc; external; 12 | {$L C:\TP\EGAVGA.OBJ } 13 | 14 | procedure SVga256Proc; external; 15 | {$L C:\TP\SVGA256.OBJ } 16 | 17 | begin 18 | end. 19 | -------------------------------------------------------------------------------- /RM/FORMAT.PAS: -------------------------------------------------------------------------------- 1 | {$I RM.INC} 2 | 3 | Unit Format; 4 | Interface 5 | uses vars,rmstrg; 6 | 7 | Procedure SetFormat(xp,yp,Ftype : Word;Var cFormat : Word;Var Frec : FormatRec); 8 | 9 | Implementation 10 | uses graph,bgigadge,bgimouse,bgiMisc,bgiImage; 11 | 12 | 13 | Type 14 | FlistT = array[1..50] of FormatRec; 15 | 16 | Var 17 | FlistPtr : ^FlistT; 18 | nFormats : Word; 19 | 20 | 21 | 22 | Procedure FstrToFrec(Fstr : String;Var Frec : FormatRec); 23 | Var 24 | TempStr : String; 25 | n : Word; 26 | begin 27 | 28 | Fstr:=Trim(UpperCase(FStr),' '); 29 | tempStr:=NextWord(Fstr,' '); 30 | Frec.PrgName:=TempStr; 31 | Fstr:=DeleteNextWord(Fstr,' '); 32 | FStr:=Trim(FStr,' '); 33 | 34 | tempStr:=NextWord(Fstr,' '); 35 | Frec.PrgPat:=TempStr; 36 | Fstr:=DeleteNextWord(Fstr,' '); 37 | FStr:=TrimL(FStr,' '); 38 | 39 | tempStr:=NextWord(Fstr,' '); 40 | Frec.PrgFormat:=TempStr; 41 | Fstr:=DeleteNextWord(Fstr,' '); 42 | FStr:=TrimL(FStr,' '); 43 | 44 | tempStr:=NextWord(Fstr,' '); 45 | Frec.PrgRW:=TempStr; 46 | Fstr:=DeleteNextWord(Fstr,' '); 47 | FStr:=TrimL(FStr,' '); 48 | 49 | Frec.PrgDis:=FStr; 50 | end; 51 | 52 | 53 | Procedure ReadExFormats(FT : Word); 54 | Var 55 | F : Text; 56 | Error : Word; 57 | FormStr : String; 58 | Frec : FormatRec; 59 | begin 60 | {$I-} 61 | {$IFDEF RMP} 62 | Assign(F,'RM.FIL'); 63 | {$ELSE} 64 | Assign(F,'MP.FIL'); 65 | {$ENDIF} 66 | Reset(F); 67 | Error:=IORESULT; 68 | If Error <>0 then Exit; 69 | While (not EOF(F)) AND (ERROR=0) AND (nFormats<50) do 70 | begin 71 | Readln(F,FormStr); 72 | FStrToFRec(FormStr,Frec); 73 | if (FT=1) AND (Frec.PrgRW='R') then 74 | begin 75 | Inc(nFormats); 76 | FlistPtr^[NFormats]:=Frec; 77 | end 78 | else if (FT=2) AND (Frec.PrgRW='W') then 79 | begin 80 | Inc(nFormats); 81 | FlistPtr^[NFormats]:=Frec; 82 | end; 83 | Error:=IORESULT; 84 | End; 85 | Close(F); 86 | Error:=IORESULT; 87 | {$I+} 88 | end; 89 | 90 | 91 | Procedure CreateFList(Ftype: Word); (* 1 = open 2=save *) 92 | begin 93 | FlistPtr^[1].PrgDis:='PCX PC Paintbrush'; 94 | FlistPTr^[1].PrgPat:='PCX'; 95 | FlistPtr^[2].PrgDis:='BMP Windows BMP'; 96 | FlistPtr^[2].PrgPat:='BMP'; 97 | FlistPtr^[3].PrgDis:='ICO Windows Icon'; 98 | FlistPtr^[3].PrgPat:='ICO'; 99 | FlistPtr^[4].PrgDis:='ICN RIP Icon'; 100 | FlistPtr^[4].PrgPat:='ICN'; 101 | 102 | {$IFDEF RMP} 103 | FlistPtr^[4].PrgDis:='CEL Autodesk Anim'; 104 | FlistPtr^[4].PrgPat:='CEL'; 105 | FlistPtr^[5].PrgDis:='RAW RM RAW'; 106 | FlistPTr^[5].PrgPat:='RAW'; 107 | FlistPtr^[6].PrgDis:='PAL Palette'; 108 | FlistPTr^[6].PrgPat:='PAL'; 109 | {$ENDIF} 110 | 111 | if Ftype = 2 then 112 | begin 113 | {$IFDEF RMP} 114 | 115 | FlistPtr^[7].PrgDis:='CHA Palette (C)'; 116 | FlistPtr^[7].PrgPat:='CHA'; 117 | 118 | FlistPtr^[8].PrgDis:='CON Palette (PAS)'; 119 | FlistPtr^[8].PrgPat:='CON'; 120 | 121 | FlistPtr^[9].PrgDis:='DAT Palette (BAS)'; 122 | FlistPtr^[9].PrgPat:='DAT'; 123 | 124 | FlistPtr^[10].PrgDis:='XGF TP/TC (Binary)'; 125 | FlistPTr^[10].PrgPat:='XGF'; 126 | 127 | FlistPtr^[11].PrgDis:='CON TP Constants'; 128 | FlistPtr^[11].PrgPat:='CON'; 129 | 130 | FlistPtr^[12].PrgDis:='CHA TC Constants'; 131 | FlistPtr^[12].PrgPat:='CHA'; 132 | 133 | FlistPtr^[13].PrgPat:='XGF'; 134 | FlistPtr^[13].PrgDis:='XGF QC/QB (Binary)'; 135 | 136 | FlistPtr^[14].PrgDis:='CHA QC Constants'; 137 | FlistPtr^[14].PrgPat:='CHA'; 138 | 139 | FlistPtr^[15].PrgDis:='DAT BASIC DATA'; 140 | FlistPtr^[15].PrgPat:='DAT'; 141 | 142 | FlistPtr^[16].PrgDis:='DEF TEGL DEF'; 143 | FlistPtr^[16].PrgPat:='DEF'; 144 | 145 | FlistPtr^[17].PrgDis:='PPR Fastgraph'; 146 | FlistPtr^[17].PrgPat:='PPR'; 147 | 148 | FlistPtr^[18].PrgDis:='SPR Fastgraph'; 149 | FlistPtr^[18].PrgPat:='SPR'; 150 | 151 | FlistPtr^[19].PrgDis:='CHA FG PPR (C)'; 152 | FlistPtr^[19].PrgPat:='CHA'; 153 | 154 | FlistPtr^[20].PrgDis:='CHA FG SPR (C)'; 155 | FlistPtr^[20].PrgPat:='CHA'; 156 | 157 | FlistPtr^[21].PrgDis:='CON FG PPR (PAS)'; 158 | FlistPtr^[21].PrgPat:='CON'; 159 | 160 | FlistPtr^[22].PrgDis:='CON FG SPR (PAS)'; 161 | FlistPtr^[22].PrgPat:='CON'; 162 | 163 | FlistPtr^[23].PrgDis:='DAT FG PPR (BAS)'; 164 | FlistPtr^[23].PrgPat:='DAT'; 165 | 166 | FlistPtr^[24].PrgDis:='DAT FG SPR (BAS)'; 167 | FlistPtr^[24].PrgPat:='DAT'; 168 | 169 | FlistPtr^[25].PrgDis:='CHA Mouse (C)'; 170 | FlistPtr^[25].PrgPat:='CHA'; 171 | 172 | FlistPtr^[26].PrgDis:='CON Mouse (PAS)'; 173 | FlistPtr^[26].PrgPat:='CON'; 174 | 175 | 176 | FlistPtr^[27].PrgDis:='DAT Mouse (BAS)'; 177 | FlistPtr^[27].PrgPat:='DAT'; 178 | nFormats:=27; 179 | {$ELSE} 180 | nFormats:=4; 181 | {$ENDIF} 182 | ReadExFormats(Ftype); 183 | end 184 | else 185 | begin 186 | {$IFDEF RMP} 187 | nFormats:=6; 188 | {$ELSE} 189 | nFormats:=4; 190 | {$ENDIF} 191 | ReadExFormats(1); 192 | end; 193 | end; 194 | 195 | 196 | 197 | Procedure SetFormat(xp,yp,Ftype : Word;Var cFormat : Word;Var Frec : FormatRec); 198 | Var 199 | FGads : GLPtr; 200 | x,y,x2,y2 : Word; 201 | offset,pos : Word; 202 | i : Word; 203 | img,P,P2 : Pointer; 204 | size,nGad : Word; 205 | 206 | 207 | Procedure PrintList(xx,yy : Word); 208 | Var 209 | i : Word; 210 | begin 211 | For i:=1 to 5 do 212 | begin 213 | if (i+offset) = Cformat then 214 | begin 215 | SetFillStyle(SolidFill,RED); 216 | end 217 | else 218 | begin 219 | SetFillStyle(SolidFill,Green); 220 | end; 221 | Bar(xx,yy+(i-1)*14,xx+170,yy+(i)*14); 222 | SetColor(Black); 223 | If nFormats >=(i+offset) then 224 | begin 225 | OutTextXY(xx+2,yy+(i-1)*14+3,FListPtr^[i+offset].PrgDis); 226 | end; 227 | end; 228 | end; 229 | 230 | begin 231 | GetMem(FlistPtr,SizeOf(FlistT)); 232 | 233 | CreateFList(Ftype); 234 | 235 | size:=ImageSize(xp,yp,xp+220,yp+140); 236 | GetMem(img,size); 237 | MouseHide; 238 | GetImage(xp,yp,xp+220,yp+140,Img^); 239 | if Ftype = 1 then 240 | begin 241 | DrawFrame(xp,yp,xp+220,yp+140,'Select Open Format'); 242 | end 243 | else 244 | begin 245 | DrawFrame(xp,yp,xp+220,yp+140,'Select Save Format'); 246 | end; 247 | GetGadgetMem(FGads,5); 248 | DefineBlankGadget(FGads,1,xp+15,yp+30,175,75,FALSE,TRUE); 249 | GetGadgetCords(FGads,1,x,y,x2,y2); 250 | 251 | If GetMaxColor=15 then 252 | begin 253 | P:=@Up16a; 254 | P2:=@Up16b; 255 | end 256 | else 257 | begin 258 | P:=@Up256a; 259 | P2:=@Up256b; 260 | end; 261 | DefineImageGadget(FGads,2,x2+2,y,17,17,P,P2,TRUE,FALSE); 262 | 263 | If GetMaxColor=15 then 264 | begin 265 | P:=@Down16a; 266 | P2:=@Down16b; 267 | end 268 | else 269 | begin 270 | P:=@Down256a; 271 | P2:=@Down256b; 272 | 273 | end; 274 | DefineImageGadget(FGads,3,x2+2,y+17,17,17,P,P2,TRUE,FALSE); 275 | 276 | DefineStringGadget(FGads,4,xp+140,y+82,' OK ',TRUE,FALSE); 277 | 278 | SetColor(Black); 279 | Rectangle(x,y,x2,y2); 280 | 281 | DrawAllGadgets(FGads,4); 282 | if cFormat < 6 then 283 | begin 284 | offset:=0; 285 | pos:=cformat; 286 | end 287 | else 288 | begin 289 | offset:=cformat-5; 290 | pos:=cformat-offset; 291 | end; 292 | PrintList(x+2,y+2); 293 | MouseShow; 294 | Repeat 295 | MouseWaitForKeyRelease; 296 | MouseWaitForAnyKey; 297 | Ngad:=GetGadgetPressed(FGads,4); 298 | If NGad > 1 then 299 | begin 300 | Repeat 301 | 302 | if NGad = 2 then 303 | begin 304 | if Pos+offset > 1 then 305 | begin 306 | if pos > 1 then 307 | begin 308 | Dec(pos); 309 | end 310 | else if offset > 0 then 311 | begin 312 | Dec(Offset); 313 | end; 314 | 315 | CFormat:=Pos+Offset; 316 | MouseHide; 317 | PrintList(x+2,y+2); 318 | MouseShow; 319 | end; 320 | end 321 | else if NGad = 3 then 322 | begin 323 | if (Pos+Offset) < NFormats then 324 | begin 325 | if Pos < 5 then 326 | begin 327 | inc(Pos); 328 | end 329 | else 330 | begin 331 | inc(offset); 332 | end; 333 | cFormat:=Pos+offset; 334 | MouseHide; 335 | PrintList(x+2,y+2); 336 | MouseShow; 337 | end; 338 | end; 339 | Until MouseIsRKey=False; 340 | 341 | MouseHide; 342 | DrawGadget(FGads,Ngad,TRUE); 343 | MouseShow; 344 | MouseWaitForKeyRelease; 345 | MouseHide; 346 | DrawGadget(FGads,Ngad,FALSE); 347 | MouseShow; 348 | 349 | end; 350 | Until nGad = 4; 351 | Frec:=FlistPtr^[cFormat]; 352 | FreeMem(FlistPtr,SizeOf(FlistT)); 353 | FreeGadgetMem(Fgads,4); 354 | Mousehide; 355 | PutImage(xp,yp,Img^,NormalPut); 356 | MouseShow; 357 | FreeMem(img,size); 358 | end; 359 | 360 | 361 | begin 362 | end. -------------------------------------------------------------------------------- /RM/KEYS.PAS: -------------------------------------------------------------------------------- 1 | Unit Keys; 2 | 3 | Interface 4 | Uses Crt; 5 | 6 | const 7 | EscKey = 27; 8 | TabKey = 9; 9 | Leftkey = 19200; 10 | Rightkey = 19712; 11 | UpKey = 18432; 12 | DownKey = 20480; 13 | DeleteKey = 21248; 14 | InsKey = 20992; 15 | BackSpace = 8; 16 | HomeKey = 18176; 17 | Endkey = 20224; 18 | EnterKey = 13; 19 | PgUpKey = 18688; 20 | PgDownKey = 20736; 21 | F1Key = 15104; 22 | F2Key = 15360; 23 | F3Key = 15616; 24 | F4Key = 15872; 25 | 26 | Function GetKey : Word; 27 | 28 | Implementation 29 | 30 | Function GetKey : Word; 31 | var 32 | key :char; 33 | key2 :word; 34 | begin 35 | Repeat until keypressed = true; 36 | key:=readkey; 37 | case key of #0:begin 38 | key := readkey; 39 | Key2 := ord(key); 40 | getkey := (key2 shl 8); 41 | exit; 42 | end; 43 | else 44 | getkey:=ord(key); 45 | exit; 46 | end; 47 | end; 48 | 49 | end. -------------------------------------------------------------------------------- /RM/MESSAGES.PAS: -------------------------------------------------------------------------------- 1 | Unit Messages; 2 | Interface 3 | uses bgiMouse,bgiMisc,bgiGadge,Graph; 4 | 5 | Function OverWriteFile(x,y : word) : Boolean; 6 | Function DoExit(x,y : word) : Boolean; 7 | Procedure ErrorMessage(x,y,ErrorNum : Word); 8 | Procedure InfoMessage(x,y : Word;msg1,msg2,msg3 : String); 9 | 10 | Implementation 11 | 12 | 13 | Function OverWriteFile(x,y : word) : Boolean; 14 | var 15 | Size : Word; 16 | Img : Pointer; 17 | ReqGads : GLPtr; 18 | gn : Word; 19 | begin 20 | MouseHide; 21 | Size:=ImageSize(x,y,x+220,y+110); 22 | GetMem(Img,Size); 23 | GetImage(x,y,x+220,y+110,Img^); 24 | 25 | DrawFrame(x,y,x+220,y+110,' WARNING!!!'); 26 | 27 | SetColor(Black); 28 | OutTextXY(x+14,y+30,' File already exists!'); 29 | OutTextXY(x+14,y+40,'Overwrite existing File?'); 30 | 31 | GetGadgetMem(ReqGads,2); 32 | DefineStringGadget(ReqGads,1,x+120,y+70,' YES ',TRUE,FALSE); 33 | DefineStringGadget(ReqGads,2,x+60, y+70,' NO ',TRUE,FALSE); 34 | DrawAllGadgets(ReqGads,2); 35 | MouseShow; 36 | 37 | Repeat 38 | MouseWaitForKeyRelease; 39 | MouseWaitForLKey; 40 | gn:=GetGadgetPressed(ReqGads,2); 41 | 42 | if gn=1 then 43 | begin 44 | OverWriteFile:=true; 45 | end 46 | else if gn=2 then 47 | begin 48 | OverWriteFile :=false; 49 | end; 50 | 51 | Until gn > 0; 52 | MouseHide; 53 | DrawGadget(ReqGads,gn,TRUE); 54 | MouseShow; 55 | MouseWaitForKeyRelease; 56 | MouseHide; 57 | DrawGadget(ReqGads,gn,FALSE); 58 | 59 | PutImage(x,y,Img^,NormalPut); 60 | FreeGadgetMem(ReqGads,2); 61 | Freemem(Img,size); 62 | MouseShow; 63 | 64 | end; 65 | 66 | Function DoExit(x,y : word) : Boolean; 67 | var 68 | Size : Word; 69 | Img : Pointer; 70 | ReqGads : GLPtr; 71 | gn : Word; 72 | begin 73 | Mousehide; 74 | Size:=ImageSize(x,y,x+220,y+110); 75 | GetMem(Img,Size); 76 | GetImage(x,y,x+220,y+110,Img^); 77 | DrawFrame(x,y,x+220,y+110,' ATTENTION!!!'); 78 | SetColor(Black); 79 | OutTextXY(x+25,y+30,'Do you really want to'); 80 | OutTextXY(x+25,y+40,'Exit ?'); 81 | 82 | 83 | GetGadgetMem(ReqGads,2); 84 | DefineStringGadget(ReqGads,1,x+120,y+70,' YES ',TRUE,FALSE); 85 | DefineStringGadget(ReqGads,2,x+60, y+70,' NO ',TRUE,FALSE); 86 | DrawAllGadgets(ReqGads,2); 87 | MouseShow; 88 | 89 | 90 | Repeat 91 | MouseWaitForKeyRelease; 92 | MouseWaitForLKey; 93 | gn:=GetGadgetPressed(ReqGads,2); 94 | 95 | if gn=1 then 96 | begin 97 | DoExit:=true; 98 | end 99 | else if gn=2 then 100 | begin 101 | DoExit:=false; 102 | end; 103 | 104 | Until gn > 0; 105 | MouseHide; 106 | DrawGadget(ReqGads,gn,TRUE); 107 | MouseShow; 108 | MouseWaitForKeyRelease; 109 | MouseHide; 110 | DrawGadget(ReqGads,gn,FALSE); 111 | 112 | PutImage(x,y,Img^,NormalPut); 113 | FreeGadgetMem(ReqGads,2); 114 | Freemem(Img,size); 115 | MouseShow; 116 | end; 117 | 118 | Procedure InfoMessage(x,y : Word;msg1,msg2,msg3 : String); 119 | var 120 | Size : Word; 121 | Img : Pointer; 122 | ReqGads : GLPtr; 123 | gn : Word; 124 | begin 125 | MouseHide; 126 | Size:=ImageSize(x,y,x+220,y+110); 127 | GetMem(Img,Size); 128 | GetImage(x,y,x+220,y+110,Img^); 129 | 130 | GetGadgetMem(ReqGads,1); 131 | DefineStringGadget(ReqGads,1,x+160,y+85,' OK ',TRUE,FALSE); 132 | 133 | 134 | DrawFrame(x,y,x+220,y+110,' ATTENTION!!!'); 135 | SetColor(Black); 136 | OutTextXY(x+10,y+35,msg1); 137 | OutTextXY(x+10,y+45,msg2); 138 | OutTextXY(x+10,y+55,msg3); 139 | DrawGadget(ReqGads,1,FALSE); 140 | 141 | MouseShow; 142 | Repeat 143 | MouseWaitForLKey; 144 | gn:=GetGadgetPressed(ReqGads,1); 145 | Until gn > 0; 146 | MouseHide; 147 | DrawGadget(ReqGads,1,TRUE); 148 | MouseShow; 149 | MouseWaitForKeyRelease; 150 | MouseHide; 151 | DrawGadget(ReqGads,1,FALSE); 152 | 153 | PutImage(x,y,Img^,NormalPut); 154 | FreeGadgetMem(ReqGads,1); 155 | Freemem(Img,size); 156 | MouseShow; 157 | 158 | end; 159 | 160 | 161 | 162 | Procedure ErrorMessage(x,y,ErrorNum : Word); 163 | var 164 | ENum : String[4]; 165 | Size : Word; 166 | Img : Pointer; 167 | ReqGads : GLPtr; 168 | gn : Word; 169 | begin 170 | MouseHide; 171 | Size:=ImageSize(x,y,x+220,y+110); 172 | GetMem(Img,Size); 173 | GetImage(x,y,x+220,y+110,Img^); 174 | 175 | Str(ErrorNum,Enum); 176 | 177 | DrawFrame(x,y,x+220,y+110,' WARNING!!!'); 178 | SetColor(Black); 179 | 180 | Case ErrorNum of 1000: OutTextXY(x+10,y+35,' Invalid File Type'); 181 | 1001: OutTextXY(x+10,y+35,' Too many colors'); 182 | 2,3002: OutTextXY(x+10,y+35,' File Not Found!'); 183 | 3: OutTextXY(x+10,y+35,' Path Not Found!'); 184 | 5: OutTextXY(x+10,y+35,' File Access Denied'); 185 | 100: OutTextXY(x+10,y+35,' Disk Read Error'); 186 | 101: OutTextXY(x+10,y+35,' Disk Write Error'); 187 | 150: OutTextXY(x+10,y+35,' Disk Is Write-Protected'); 188 | 152: OutTextXY(x+10,y+35,' Drive Not Ready'); 189 | 156: OutTextXY(x+10,y+35,' Disk Seek Error'); 190 | 162: OutTextXY(x+10,y+35,' Hardware Failure'); 191 | else 192 | begin 193 | OutTextXY(x+10,y+30,' I/O error #'+Enum+' has'); 194 | OutTextXY(x+10,y+40,' Occured!'); 195 | end; 196 | END; 197 | GetGadgetMem(ReqGads,1); 198 | DefineStringGadget(ReqGads,1,x+85,y+70,' OK ',TRUE,FALSE); 199 | DrawGadget(ReqGads,1,FALSE); 200 | MouseShow; 201 | 202 | Repeat 203 | MouseWaitForKeyRelease; 204 | MouseWaitForLKey; 205 | gn:=GetGadgetPressed(ReqGads,1); 206 | until gn > 0; 207 | MouseHide; 208 | DrawGadget(ReqGads,1,TRUE); 209 | MouseShow; 210 | MouseWaitForKeyRelease; 211 | MouseHide; 212 | DrawGadget(ReqGads,1,FALSE); 213 | PutImage(x,y,Img^,NormalPut); 214 | MouseShow; 215 | Freemem(Img,size); 216 | FreeGadgetMem(ReqGads,1); 217 | end; 218 | 219 | 220 | begin 221 | end. -------------------------------------------------------------------------------- /RM/RM.INC: -------------------------------------------------------------------------------- 1 | {$DEFINE RMP} 2 | -------------------------------------------------------------------------------- /RM/RM.PAS: -------------------------------------------------------------------------------- 1 | {$I RM.INC} 2 | 3 | 4 | {$IFDEF RMP} 5 | {$M 51000,0,140000} 6 | {$ELSE} 7 | {$M 52000,0,140000} 8 | {$ENDIF} 9 | 10 | {$S+} 11 | Program RM; 12 | uses crt, 13 | graph, 14 | keys, 15 | vars, 16 | panel, 17 | tools, 18 | bgimouse, 19 | dos, 20 | bgiReq, 21 | Messages, 22 | Format, 23 | Screen, 24 | rmTitle; 25 | 26 | Var 27 | n : Word; 28 | RKey : Boolean; 29 | 30 | 31 | Procedure DrawScreen; 32 | begin 33 | GetGadgetMemory; 34 | SetMainToolGadget(2,110); 35 | SetMainGridGadget(115,5); 36 | SetMainColorGadget(111,431); 37 | SetHorizScrollers(110,411); 38 | SetVirtScrollers(620,0); 39 | SetToolGadgets(2,110); 40 | SetClipGadgets(2,110); 41 | SetColorGadgets(111,431); 42 | Setfillstyle(SolidFill,Black); 43 | 44 | Bar(0,0,639,469); 45 | MouseColrange(0,629); 46 | MouseRowrange(0,464); 47 | 48 | DrawActualBox(5,4); 49 | DrawColorGadgets; 50 | DrawGridBox(115,5); 51 | DrawToolGadgets; 52 | DrawRMBox(2,350); 53 | DrawScrollGadgets; 54 | end; 55 | 56 | Procedure Init; 57 | begin 58 | If MouseExists then 59 | begin 60 | if SetSVGA16(3) then 61 | begin 62 | DrawScreen; 63 | end 64 | else 65 | begin 66 | Writeln('This Program requires a Mouse and a VGA card.'); 67 | write(#7); 68 | halt(1); 69 | end; 70 | end 71 | else 72 | begin 73 | Writeln('This Program requires a Mouse and VGA card.'); 74 | halt(1); 75 | end; 76 | 77 | end; 78 | 79 | begin 80 | Init; 81 | MouseMode(1); 82 | MouseShow; 83 | 84 | repeat 85 | MouseWaitForAnyKey; 86 | Rkey:=MouseIsRKey; 87 | n:=GetMainGadget; 88 | If n=1 then 89 | begin 90 | n:=GetToolGadget; 91 | if n = 1 then 92 | begin 93 | If RKey then 94 | begin 95 | OpenFormatP; 96 | end 97 | else 98 | begin 99 | SaveUndoImg; 100 | OpenP; 101 | end; 102 | end 103 | else if n = 2 then 104 | begin 105 | If RKey then 106 | begin 107 | SaveFormatp; 108 | end 109 | else 110 | begin 111 | SaveP; 112 | end; 113 | end 114 | Else if n = 3 then 115 | begin 116 | SaveUndoImg; 117 | CLRP; 118 | end 119 | else if n = 4 then 120 | begin 121 | UndoP; 122 | end 123 | else if n = 5 then 124 | begin 125 | GridP; 126 | end 127 | else if n = 6 then 128 | begin 129 | GridAdjustP; 130 | end 131 | else if n = 7 then 132 | begin 133 | ViewP; 134 | end 135 | else if n = 8 then 136 | begin 137 | FreeGadgetMemory; 138 | TogleMode; 139 | DrawScreen; 140 | ReDrawImage; 141 | MouseShow; 142 | end 143 | else if n = 9 then 144 | begin 145 | if DoExit(80,221) then 146 | begin 147 | FreeGadgetMemory; 148 | MouseHide; 149 | ClearDevice; 150 | Closegraph; 151 | EndTitle; 152 | halt; 153 | end; 154 | end; 155 | end 156 | else if n=2 then 157 | begin 158 | n:=GetColorGadget; 159 | if n=1 then 160 | begin 161 | SelectColor; 162 | end 163 | else if n= 2then 164 | begin 165 | Pal; 166 | end 167 | else if n= 3 then 168 | begin 169 | UpColors; 170 | end 171 | else if n=4 then 172 | begin 173 | DownColors; 174 | end; 175 | MouseWaitForKeyRelease; 176 | end 177 | else if n=3 then 178 | begin 179 | SaveUndoImg; 180 | case tool of 181 | 1:ClipP; 182 | 2:FillP; 183 | 3:CircleP; 184 | 4:FCircleP; 185 | 5:SprayP; 186 | 6:DotP; 187 | 7:RectangleP; 188 | 8:FRectangleP; 189 | 9:LineP; 190 | end; 191 | end 192 | else 193 | begin 194 | n:=GetScrollGadget; 195 | case n of 1:SweepLeft; 196 | 2:SweepRight; 197 | 3:SweepH; 198 | 4:SweepUp; 199 | 5:SweepDown; 200 | 6:SweepV; 201 | end; 202 | end; 203 | 204 | Until 1=0; 205 | 206 | end. -------------------------------------------------------------------------------- /RM/RML16.OBJ: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RetroNick2020/raster-master-dos/51aa355531856ace663ac7eb4b65d02a39230bb7/RM/RML16.OBJ -------------------------------------------------------------------------------- /RM/RML16.XGF: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RetroNick2020/raster-master-dos/51aa355531856ace663ac7eb4b65d02a39230bb7/RM/RML16.XGF -------------------------------------------------------------------------------- /RM/RML256.OBJ: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RetroNick2020/raster-master-dos/51aa355531856ace663ac7eb4b65d02a39230bb7/RM/RML256.OBJ -------------------------------------------------------------------------------- /RM/RML256.XGF: -------------------------------------------------------------------------------- 1 | H                                                                   -------------------------------------------------------------------------------- /RM/RMLOGO.BMP: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RetroNick2020/raster-master-dos/51aa355531856ace663ac7eb4b65d02a39230bb7/RM/RMLOGO.BMP -------------------------------------------------------------------------------- /RM/RMSTRG.PAS: -------------------------------------------------------------------------------- 1 | Unit RMSTRG; 2 | 3 | Interface 4 | 5 | Function StrHex(Num : longint;Field : byte) : String; 6 | Function ValBin(S:String;VAR code : integer) : Longint; 7 | function UpperCase(S : String) : string; 8 | 9 | 10 | (*function _WrdPosL(S:string;Nth : byte) : byte; 11 | *) 12 | Function Hex(i:LongInt; Lgt:Byte):String; 13 | function Trim(S: string; DelChar : char): string; 14 | function TrimL(S : String; DelChar : char) : string; 15 | function TrimR(S : String; DelChar : char) : string; 16 | 17 | 18 | 19 | function NextWord(S : String; Sep : string) : string; 20 | function DeleteNextWord(S : String; Sep : string) : string; 21 | 22 | Implementation 23 | 24 | Function Hex(i:LongInt; Lgt:Byte):String; 25 | { Return i in hex with at least Lgt chars. 26 | Lgt is byte so I don't have to check for values > 255. If another 27 | type was used, and a value > 255 was passed in, the routine would 28 | loop indefinitely. 29 | } 30 | Const 31 | HexDigs:Array[0..15] of Char = '0123456789ABCDEF'; 32 | Var 33 | s : String; 34 | Begin 35 | s := ''; 36 | Repeat 37 | s := HexDigs[i and $F] + s; 38 | i := i shr 4; 39 | until (i = 0) and (length(s) >= Lgt); 40 | Hex := s; 41 | End; 42 | 43 | Function StrHex(Num : longint;Field : byte) : String; 44 | begin 45 | StrHex:=Hex(Num,Field); 46 | end; 47 | 48 | function bin2dec (s : string) : longint; 49 | var 50 | tmp : longint; 51 | p : byte; 52 | begin 53 | tmp := 0; 54 | for p := 1 to length(s) do 55 | begin 56 | inc(tmp,longint(ord(s[length(s)])-48) shl pred(p)); 57 | dec(s[0]); 58 | end; 59 | bin2dec := tmp; 60 | end; 61 | 62 | Function ValBin(S:String;VAR code : integer) : Longint; 63 | begin 64 | code:=0; 65 | ValBin:=Bin2Dec(S); 66 | end; 67 | 68 | function UpperCase(S : String) : string; 69 | var 70 | i : byte; 71 | begin 72 | for i:=1 to Length(S) do 73 | begin 74 | s[i] := UpCase(s[i]); 75 | end; 76 | UpperCase:=S; 77 | end; 78 | 79 | function TrimL(S : String; DelChar : char) : string; 80 | begin 81 | while (Length(s) > 0) and (Pos(DelChar,S) = 1) Do 82 | begin 83 | Delete(S,1,1); 84 | end; 85 | TrimL:=S; 86 | end; 87 | 88 | function TrimR(S : String; DelChar : char) : string; 89 | begin 90 | while (Length(s) > 0) and (S[Length(S)] = DelChar) Do 91 | begin 92 | Delete(S,Length(S),1); 93 | end; 94 | TrimR:=S; 95 | end; 96 | 97 | 98 | function Trim(S: string; DelChar : char): string; 99 | begin 100 | S:=TrimL(S,DelChar); 101 | S:=TrimR(S,DelChar); 102 | Trim:=S; 103 | end; 104 | 105 | function NextWord(S : String; Sep : string) : string; 106 | var 107 | npos : integer; 108 | begin 109 | npos:=POS(sep,S); 110 | if npos = 0 then NextWord:=S else NextWord:=Copy(S,1,npos-1); 111 | end; 112 | 113 | function DeleteNextWord(S : String; Sep : string) : string; 114 | var 115 | npos : integer; 116 | begin 117 | npos:=POS(sep,S); 118 | if npos = 0 then 119 | begin 120 | DeleteNextWord:=''; 121 | end 122 | else 123 | begin 124 | Delete(S,1,npos); 125 | DeleteNextWord:=S; 126 | end; 127 | end; 128 | 129 | 130 | (* finds position of word delimited by spaces *) 131 | function _WrdPosL(S:string;Nth : byte) : byte; 132 | begin 133 | end; 134 | 135 | 136 | 137 | begin 138 | end. -------------------------------------------------------------------------------- /RM/RMTITLE.PAS: -------------------------------------------------------------------------------- 1 | {$I RM.INC} 2 | 3 | Unit rmtitle; 4 | Interface 5 | uses crt,dos,vars,xgraph,graph,bgigadge,bgimouse,bgimisc; 6 | 7 | Procedure EndTitle; 8 | Procedure StartMenu(x,y : word); 9 | 10 | Implementation 11 | 12 | 13 | Procedure Wait(Sds : Word); 14 | Var 15 | nPassed : Word; 16 | sec,min,hour,sec100 : Word; 17 | lastsec : Word; 18 | begin 19 | nPassed:=0; 20 | LastSec:=0; 21 | Repeat 22 | GetTime(hour,min,sec,sec100); 23 | if sec <> LastSec then 24 | begin 25 | inc(nPassed); 26 | Lastsec:=sec; 27 | end; 28 | 29 | Until npassed > Sds; 30 | end; 31 | 32 | 33 | Procedure EndTitle; 34 | begin 35 | Writeln(ProgramName); 36 | Writeln(CopyRight1+' '+Copyright2); 37 | Writeln; 38 | Writeln(GitHub1); 39 | Writeln(GitHub2); 40 | Writeln; 41 | end; 42 | 43 | Procedure StartMenu(x,y : word); 44 | const width = 369; 45 | height = 169; 46 | var 47 | ReqGads : GLPtr; 48 | gn : Word; 49 | size : Word; 50 | Img : Pointer; 51 | 52 | begin 53 | size:=xgraph.ImageSize(x,y,x+width,y+height); 54 | GetMem(Img,size); 55 | GetGadgetMem(ReqGads,1); 56 | DefineStringGadget(ReqGads,1,x+width-40,y+height-30,' OK ',TRUE,FALSE); 57 | MouseHide; 58 | GetImage(x,y,x+width,y+height,Img^); 59 | SetFillStyle(SolidFill,White); 60 | Bar(x+3,y+3,x+width-3,y+height-3); 61 | Border(x,y,x+width,y+height); 62 | SetColor(LightRed); 63 | OutTextXY(x+100,y+10,ProgramName); 64 | SetColor(black); 65 | Rectangle(x+2,y+2,x+width-2,y+height-2); 66 | OutTextXY(x+10,y+25,Copyright1); 67 | OutTextXY(x+42,y+35,Copyright2); 68 | 69 | 70 | DrawGadget(ReqGads,1,FALSE); 71 | MouseShow; 72 | Repeat 73 | MouseWaitForKeyRelease; 74 | MouseWaitForLKey; 75 | gn:=GetGadgetPressed(ReqGads,1); 76 | until gn > 0; 77 | MouseHide; 78 | DrawGadget(reqGads,gn,TRUE); 79 | MouseShow; 80 | MouseWaitForKeyRelease; 81 | MouseHide; 82 | DrawGadget(reqGads,gn,FALSE); 83 | PutImage(x,y,Img^,normalput); 84 | Freemem(Img,size); 85 | FreeGadgetMem(ReqGads,1); 86 | MouseShow; 87 | end; 88 | 89 | 90 | begin 91 | end. 92 | -------------------------------------------------------------------------------- /RM/RRES.PAS: -------------------------------------------------------------------------------- 1 | Unit rres; 2 | 3 | Interface 4 | uses graph; 5 | 6 | const 7 | MaxResItems = 255; 8 | type 9 | resrec = Record 10 | rt : integer; 11 | rid : array[1..12] of char; 12 | offset : longint; 13 | size : longint; 14 | end; 15 | 16 | resIndex = array[1..MaxResItems] of resrec; 17 | 18 | RFILE = Record 19 | ResFile : File; 20 | ResList : ^resIndex; 21 | ResItems : integer; 22 | end; 23 | 24 | Procedure res_open(Var IRFILE : RFILE;filename : string); 25 | Procedure res_close(var IRFILE : RFILE); 26 | Function res_getsize(VAR IRFILE : RFILE; ri : integer) : longint; 27 | Procedure res_read(VAR IRFILE : RFILE; var rbuf; ri : integer); 28 | Procedure res_dis_xgf(Var IRFILE : RFILE; x,y : integer;ri : integer;dmode : integer); 29 | 30 | 31 | Implementation 32 | 33 | Procedure res_open(Var IRFILE : RFILE;filename : string); 34 | type 35 | ExeHeaderRec = Record 36 | Sig : Word; (* EXE File signature *) 37 | bleft : Word; (* Number of Bytes in last page of EXE image*) 38 | nPages : Word; (* Number of 512 Byte pages in EXE image *) 39 | end; 40 | 41 | Var 42 | i,error : word; 43 | ressig : array[1..3] of char; 44 | ExeHeader : ExeHeaderRec; 45 | ExeSize : LongInt; 46 | begin 47 | {$I-} 48 | assign(IRFILE.Resfile,filename); 49 | Reset(IRFILE.ResFile,1); 50 | error:=ioresult; 51 | if error <> 0 then 52 | begin 53 | writeln('error opening resource file ',filename); 54 | halt; 55 | end; 56 | 57 | exesize:=0; 58 | If Filename=ParamStr(0) then 59 | begin 60 | BlockRead(IRFILE.ResFile,ExeHeader,SizeOf(ExeHeaderRec)); 61 | ExeSize:=Longint(ExeHeader.bleft)+LongInt((ExeHeader.npages-1))*512; 62 | Seek(IRFILE.ResFile,ExeSize); 63 | end; 64 | 65 | blockread(IRFILE.Resfile,ressig,3); 66 | if ressig <> 'RES' then 67 | begin 68 | writeln('not a valid resource file'); 69 | halt; 70 | end; 71 | 72 | blockread(IRFILE.resfile,IRFILE.resitems,2); 73 | getmem(IRFILE.reslist,sizeof(resrec)*IRFILE.resitems); 74 | blockread(IRFILE.resfile,IRFILE.reslist^,sizeof(resrec)*IRFILE.resitems); 75 | error:=ioresult; 76 | if error<>0 then 77 | begin 78 | writeln('error reading resource file header'); 79 | halt; 80 | end; 81 | 82 | For i:=1 to IRFILE.resitems do 83 | begin 84 | Inc(IRFILE.ResList^[i].offset,exesize); 85 | end; 86 | 87 | {$I+} 88 | end; 89 | 90 | Procedure res_close(var IRFILE : RFILE); 91 | var 92 | error : word; 93 | begin 94 | {$I-} 95 | close(IRFILE.resfile); 96 | Freemem(IRFILE.reslist,sizeof(resrec)*IRFILE.resitems); 97 | error:=ioresult; 98 | if error <> 0 then 99 | begin 100 | writeln('error closing resource file'); 101 | halt; 102 | end; 103 | {$I+} 104 | end; 105 | 106 | Function res_getsize(VAR IRFILE : RFILE; ri : integer) : longint; 107 | begin 108 | res_getsize:=IRFILE.reslist^[ri].size; 109 | end; 110 | 111 | Procedure res_read(VAR IRFILE : RFILE; var rbuf; ri : integer); 112 | var 113 | error : word; 114 | begin 115 | {$I-} 116 | seek(IRFILE.resfile,IRFILE.reslist^[ri].offset); 117 | blockread(IRFILE.resfile,rbuf,IRFILE.reslist^[ri].size); 118 | error:=ioresult; 119 | if error <> 0 then 120 | begin 121 | writeln('error reading resource file'); 122 | halt; 123 | end; 124 | {$I+} 125 | end; 126 | 127 | Procedure res_dis_xgf(Var IRFILE : RFILE; x,y : integer;ri : integer;dmode : integer); 128 | var 129 | width,height : integer; 130 | bpl,i,error : integer; 131 | scanline : array[1..1030] of integer; 132 | begin 133 | {$I-} 134 | seek(IRFILE.resfile,IRFILE.reslist^[ri].offset); 135 | blockread(IRFILE.resfile,width,2); 136 | blockread(IRFILE.resfile,height,2); 137 | 138 | scanline[1]:=width; 139 | scanline[2]:=0; 140 | 141 | if (getmaxcolor=255) then 142 | begin 143 | bpl:=width+1; 144 | end 145 | else 146 | begin 147 | bpl:=imagesize(0,0,width,0)-6; 148 | end; 149 | 150 | for i:=0 to height do 151 | begin 152 | blockread(IRFILE.resfile,scanline[3],bpl); 153 | putimage(x,y+i,Ptr(seg(scanline),ofs(scanline))^,dmode); 154 | end; 155 | {$I+} 156 | end; 157 | 158 | begin 159 | (* 160 | writeln(memavail); 161 | res_open(myres,'c:\mm\gfx\marble.res'); 162 | setvga256; 163 | res_read(myres,mypal,1); 164 | SetPaletteList(mypal,256); 165 | 166 | 167 | res_dis_xgf(myres,1,0,2,0); 168 | res_dis_xgf(myres,110,0,3,0); 169 | res_dis_xgf(myres,10,80,8,0); 170 | 171 | 172 | repeat until keypressed; 173 | closegraph; 174 | res_close(myres); 175 | writeln(memavail); 176 | *) 177 | end. 178 | -------------------------------------------------------------------------------- /RM/RWBMP.PAS: -------------------------------------------------------------------------------- 1 | Unit rwbmp; 2 | Interface 3 | Function ReadBMP(x,y,x2,y2,lp : Word;Filename : String) : Word; 4 | Function WriteBMP(x,y,x2,y2 : Word;Filename : String) : Word; 5 | Implementation 6 | uses vars,core,dos,graph,bgiPal; 7 | 8 | type 9 | bmpRec = Record 10 | ID : Array[1..2] of CHAR; 11 | Fsize : LongInt; 12 | reserved1 : Word; 13 | reserved2 : Word; 14 | offbits : LongInt; 15 | 16 | biSize : LongInt; 17 | biWidth : LongInt; 18 | biHeight : Longint; 19 | biPlanes : Word; 20 | bits : Word; 21 | biCompression : LongInt; 22 | biSizeImage : LongInt; 23 | biXpelsPerMeter : LongInt; 24 | biyPelsPerMeter : LongInt; 25 | biClrUsed : LongInt; 26 | biClrImportant : LongInt; 27 | End; 28 | 29 | 30 | bmpRGB = Record 31 | blue : byte; 32 | green : byte; 33 | red : byte; 34 | filler : byte; 35 | End; 36 | 37 | LineBufType = Array[0..1023] of Byte; 38 | 39 | Procedure PackedToSingle(Var imgLine,uline : lineBufType;bpl,width : Word); 40 | Var 41 | i : Word; 42 | xp : Word; 43 | begin 44 | xp:=0; 45 | for i:=0 to BPL-1 do 46 | begin 47 | uline[xp+1]:=imgLine[i] SHL 4; 48 | uline[xp+1]:=uline[xp+1] SHR 4; 49 | uline[xp]:=imgLine[i] SHR 4; 50 | inc(xp,2); 51 | if xp>=Width then exit; 52 | end; 53 | end; 54 | 55 | Procedure SingleToPacked(Var uline,imgline : lineBufType;bpl : Word); 56 | Var 57 | i : Word; 58 | xp : Word; 59 | begin 60 | xp:=0; 61 | for i:=0 to bpl-1 do 62 | begin 63 | imgline[i]:=(uLine[xp] SHL 4)+uline[xp+1]; 64 | inc(xp,2); 65 | end; 66 | end; 67 | 68 | Function ReadBMP(x,y,x2,y2,lp : Word;Filename : String) : Word; 69 | Var 70 | mybmp : bmpRec; 71 | myWidth : Word; 72 | myHeight : Word; 73 | myColNum : Word; 74 | FSize : LONGINT; 75 | BPL : Word; 76 | F : File; 77 | uline, 78 | imgline : lineBufType; 79 | bmpPal : Array[0..255] of bmpRGB; 80 | stdPal : PaletteT; 81 | i,j : Word; 82 | Error : Word; 83 | begin 84 | myHeight:=y2-y+1; 85 | myWidth:=x2-x+1; 86 | {$I-} 87 | assign(F,filename); 88 | reset(F,1); 89 | FSize:=FileSize(F); 90 | Blockread(F,mybmp,sizeof(mybmp)); 91 | 92 | Error:=IORESULT; 93 | if Error <> 0 then 94 | begin 95 | ReadBMP:=Error; 96 | exit; 97 | end; 98 | 99 | if NOT ((mybmp.biCompression=0) AND (mybmp.ID='BM') AND ((mybmp.bits=4) OR (mybmp.bits=8))) then 100 | begin 101 | ReadBMP:=1000; 102 | Close(F); 103 | Error:=IORESULT; 104 | exit; 105 | end; 106 | 107 | if myHeight>mybmp.biHeight then 108 | begin 109 | myHeight:=myBmp.biHeight; 110 | end; 111 | 112 | if myWidth>mybmp.biWidth then 113 | begin 114 | myWidth:=myBmp.biWidth; 115 | end; 116 | 117 | myColNum:=1 SHL myBmp.bits; 118 | if myBmp.Bits=4 then 119 | begin 120 | blockread(f,bmpPal,64); 121 | BPL:=((myBmp.biWidth+7) div 8); 122 | BPL:=(BPL*8) DIV 2; 123 | Seek(F,FSize-LONGINT(bpl)*LONGINT(myHeight)); 124 | for j:=myHeight downto 1 do 125 | begin 126 | Blockread(f,imgLine,BPL); 127 | Error:=IORESULT; 128 | if Error <> 0 then 129 | begin 130 | Close(F); 131 | ReadBMP:=Error; 132 | exit; 133 | end; 134 | PackedToSingle(imgLine,Uline,BPL,myWidth); 135 | For i:=1 to myWidth do 136 | begin 137 | IconImage[x+i-1,y+j-1]:=Uline[i-1]; 138 | end; 139 | end; 140 | end 141 | else if myBmp.bits=8 then 142 | begin 143 | blockread(f,bmpPal,1024); 144 | Error:=IORESULT; 145 | if Error <> 0 then 146 | begin 147 | Close(F); 148 | ReadBMP:=Error; 149 | exit; 150 | end; 151 | BPL:=(mybmp.biWidth+3) div 4; 152 | BPL:=BPL*4; 153 | Seek(F,FSize-LONGINT(bpl)*LONGINT(myHeight)); 154 | for j:=myHeight downto 1 do 155 | begin 156 | Blockread(f,ULine,BPL); 157 | For i:=1 to myWidth do 158 | begin 159 | IconImage[x+i-1,y+j-1]:=Uline[i-1]; 160 | end; 161 | end; 162 | end 163 | else 164 | begin 165 | ReadBMP:=1000; 166 | Close(F); 167 | Error:=IORESULT; 168 | exit; 169 | end; 170 | 171 | Close(f); 172 | if GetMaxColor < (myColNum-1) then 173 | begin 174 | myColNum:=GetMaxColor+1; 175 | ReduceTo16; 176 | end; 177 | 178 | if lp=1 then 179 | begin 180 | For i:=0 to myColNum-1 do 181 | begin 182 | StdPal[i,0]:=bmpPal[i].red SHR 2; 183 | StdPal[i,1]:=bmpPal[i].green SHR 2; 184 | StdPal[i,2]:=bmpPal[i].blue SHR 2; 185 | end; 186 | SetPaletteList(StdPal,myColNum); 187 | end; 188 | 189 | Error:=IORESULT; 190 | ReadBMP:=Error; 191 | {$I+} 192 | end; 193 | 194 | 195 | Function WriteBMP(x,y,x2,y2 : Word;Filename : String) : Word; 196 | Var 197 | mybmp : bmpRec; 198 | myWidth : Word; 199 | myHeight : Word; 200 | myNumCol : Word; 201 | BPL : Word; 202 | F : File; 203 | uline, 204 | imgline : lineBufType; 205 | bmpPal : Array[0..255] of bmpRGB; 206 | stdPal : PaletteT; 207 | i,j : Word; 208 | Error : Word; 209 | begin 210 | myHeight:=y2-y+1; 211 | myWidth:=x2-x+1; 212 | myNumCol:=GetMAxColor+1; 213 | If MyNumCol=16 then 214 | begin 215 | BPL:=(myWidth+7) Div 8; 216 | BPL:=(BPL*8) DIV 2; 217 | end 218 | else 219 | begin 220 | BPL:=(myWidth+3) div 4; 221 | BPL:=BPL*4; 222 | end; 223 | FillChar(myBmp,SizeOf(myBMP),0); 224 | mybmp.ID:='BM'; 225 | mybmp.offbits :=SizeOf(myBMP)+(mynumCol*4); 226 | mybmp.Fsize :=mybmp.offbits+(BPL*myHeight); 227 | mybmp.biSize :=40; 228 | mybmp.biWidth :=myWidth; 229 | mybmp.biHeight:=myHeight; 230 | mybmp.biPlanes:=1; 231 | mybmp.bisizeImage:=mybmp.fsize-mybmp.offbits; 232 | if myNumCol=16 then 233 | begin 234 | mybmp.bits:=4; 235 | end 236 | else 237 | begin 238 | mybmp.bits:=8; 239 | end; 240 | 241 | GrabPaletteList(StdPal,myNumCol); 242 | For i:=0 to myNumCol-1 do 243 | begin 244 | bmpPal[i].red:=StdPal[i,0] SHL 2; 245 | bmpPal[i].green:=StdPal[i,1] SHL 2; 246 | bmpPal[i].blue:=StdPal[i,2] SHL 2; 247 | bmpPal[i].filler:=0; 248 | end; 249 | 250 | {$I-} 251 | assign(F,filename); 252 | rewrite(F,1); 253 | 254 | BlockWrite(F,mybmp,sizeof(mybmp)); 255 | error:=IORESULT; 256 | if Error<>0 then 257 | begin 258 | WriteBMP:=Error; 259 | Close(F); 260 | Error:=IORESULT; 261 | exit; 262 | end; 263 | 264 | 265 | BlockWrite(F,bmpPal,myNumCol*4); 266 | 267 | if myNumCol=16 then 268 | begin 269 | For j:=y2 downto y do 270 | begin 271 | For i:=1 to myWidth do 272 | begin 273 | uline[i-1]:=IconImage[x+i-1,j]; 274 | end; 275 | SingleToPacked(uline,imgline,BPL); 276 | BlockWrite(F,imgLine,BPL); 277 | error:=IORESULT; 278 | if Error<>0 then 279 | begin 280 | WriteBMP:=Error; 281 | Close(F); 282 | Error:=IORESULT; 283 | exit; 284 | end; 285 | end; 286 | end 287 | else 288 | begin 289 | For j:=y2 downto y do 290 | begin 291 | For i:=1 to myWidth do 292 | begin 293 | uline[i-1]:=IconImage[x+i-1,j]; 294 | end; 295 | BlockWrite(F,uLine,BPL); 296 | error:=IORESULT; 297 | if Error<>0 then 298 | begin 299 | WriteBMP:=Error; 300 | Close(F); 301 | Error:=IORESULT; 302 | exit; 303 | end; 304 | end; 305 | end; 306 | Close(F); 307 | Error:=IORESULT; 308 | WriteBMP:=Error; 309 | {$I+} 310 | end; 311 | 312 | begin 313 | end. -------------------------------------------------------------------------------- /RM/RWCEL.PAS: -------------------------------------------------------------------------------- 1 | Unit RWCEL; 2 | Interface 3 | Function WriteCEL(x,y,x2,y2 : Word;FileName : String) : Word; 4 | Function ReadCEL(x,y,x2,y2,pal : Word;FileName : String) : Word; 5 | Implementation 6 | uses vars,graph,bgipal,core; 7 | 8 | Type 9 | CELRec = Record 10 | mgNum : Word; 11 | Width : Word; 12 | Height : Word; 13 | x : Word; 14 | y : Word; 15 | Bits : Byte; 16 | Comp : Byte; 17 | ImgSize : LongInt; 18 | Filler : Array[1..16] of Byte; 19 | End; 20 | 21 | Function WriteCEL(x,y,x2,y2 : Word;FileName : String) : Word; 22 | Var 23 | Error : Word; 24 | i,j : Word; 25 | F : File; 26 | Width : Word; 27 | Height : Word; 28 | Colors : Word; 29 | Tbuf : Array[1..100] of Byte; 30 | myPal : PaletteT; 31 | myCEL : CELRec; 32 | begin 33 | Width:=x2-x+1; 34 | Height:=y2-y+1; 35 | Colors:=GetMaxColor+1; 36 | 37 | FillChar(myCEL,SizeOf(myCEL),0); 38 | myCel.mgNum:=$9119; 39 | myCel.Width:=Width; 40 | myCel.Height:=Height; 41 | myCel.Bits:=8; 42 | myCel.ImgSize:=(Width*Height); 43 | 44 | GrabPaletteList(myPal,256); 45 | 46 | {$I-} 47 | Assign(F,FileName); 48 | Rewrite(F,1); 49 | BlockWrite(F,myCEL,SizeOf(myCEL)); 50 | 51 | BlockWrite(F,myPal,768); 52 | 53 | For j:=y to y2 do 54 | begin 55 | For i:=1 to Width do 56 | begin 57 | Tbuf[i]:=IconImage[x+i-1,j]; 58 | end; 59 | BlockWrite(F,TBuf,Width); 60 | Error:=IORESULT; 61 | If Error<>0 then 62 | begin 63 | WriteCEL:=Error; 64 | Exit; 65 | end; 66 | end; 67 | 68 | Close(F); 69 | Error:=IORESULT; 70 | WriteCEL:=Error; 71 | {$I+} 72 | end; 73 | 74 | Function ReadCEL(x,y,x2,y2,pal : Word;FileName : String) : Word; 75 | Var 76 | Error: Word; 77 | i ,j : Word; 78 | F : File; 79 | Colors : Word; 80 | myWidth,myHeight : Word; 81 | Fcol : Byte; 82 | Tbuf : array[0..1023] of byte; 83 | myPal : PaletteT; 84 | size,fsize : LongInt; 85 | myCel : CELRec; 86 | begin 87 | myWidth:=x2-x+1; 88 | myHeight:=y2-y+1; 89 | Colors:=256; 90 | {$I-} 91 | Assign(F,FileName); 92 | Reset(F,1); 93 | Error:=IORESULT; 94 | if Error <>0 then 95 | begin 96 | ReadCEL:=Error; 97 | Exit; 98 | end; 99 | 100 | fsize:=FileSize(F); 101 | 102 | BlockRead(F,myCEL,SizeOf(myCEL)); 103 | BlockRead(F,myPal,768); 104 | Error:=IORESULT; 105 | 106 | Size:=myCEL.Width*myCEL.Height+32+768; 107 | 108 | if (size<>fsize) OR (myCEL.mgNum<>$9119) OR (Error<>0)then 109 | begin 110 | Close(f); 111 | ReadCEL:=1000; 112 | Error:=IORESULT; 113 | Exit; 114 | end; 115 | 116 | If myHeight > myCel.Height then myHeight:=myCel.Height; 117 | if myWidth > myCel.Width then myWidth:=myCel.Width; 118 | For j:=1 to myHeight do 119 | begin 120 | BlockRead(F,TBuf,myCel.Width); 121 | Error:=IORESULT; 122 | If Error<>0 then 123 | begin 124 | ReadCEL:=Error; 125 | Exit; 126 | end; 127 | For i:=1 to myWidth do 128 | begin 129 | IconImage[x+i-1,y+j-1]:=Tbuf[i-1]; 130 | end; 131 | end; 132 | Close(F); 133 | If (GetMaxColor=15) then 134 | begin 135 | ReduceTo16; 136 | end; 137 | if Colors > (GetMaxColor+1) then Colors:=GetMaxColor+1; 138 | If Pal=1 then 139 | begin 140 | If Colors > 0 Then SetPaletteList(myPal,Colors); 141 | end; 142 | Error:=IORESULT; 143 | ReadCEL:=Error; 144 | {$I+} 145 | end; 146 | 147 | begin 148 | end. -------------------------------------------------------------------------------- /RM/RWCUSTOM.PAS: -------------------------------------------------------------------------------- 1 | Unit RWCUSTOM; 2 | 3 | Interface 4 | Uses Vars; 5 | 6 | Function WriteCustom(x,y,x2,y2 : Word;wf : FormatRec; filename : String) : Word; 7 | Function ReadCustom(x,y,x2,y2,pal : Word;wf : FormatRec; filename : String) : Word; 8 | 9 | Implementation 10 | Uses Dos,Graph,RWXGF; 11 | 12 | Function WriteCustom(x,y,x2,y2 : Word;wf : FormatRec; filename : String) : Word; 13 | Var 14 | Error : Word; 15 | F : File; 16 | begin 17 | Error:=WriteRaw(x,y,x2,y2,'RM$$.RAW'); 18 | if Error <> 0 then 19 | begin 20 | WriteCustom:=Error; 21 | Exit; 22 | end; 23 | Exec(wf.PrgName,filename+' '+wf.PrgFormat); 24 | Error:=DosError; 25 | if Error <> 0 then 26 | begin 27 | WriteCustom:=2000+Error; 28 | Exit; 29 | end; 30 | Error:=DosExitCode; 31 | if Error <> 0 then 32 | begin 33 | WriteCustom:=3000+Error; 34 | Exit; 35 | end; 36 | WriteCustom:=0; 37 | {$I-} 38 | Assign(F,'RM$$.RAW'); 39 | Erase(F); 40 | Error:=IORESULT; 41 | {$I+} 42 | end; 43 | 44 | 45 | Function ReadCustom(x,y,x2,y2,pal : Word;wf : FormatRec; filename : String) : Word; 46 | Var 47 | Error : Word; 48 | Xstr,YStr,X2Str,Y2Str,PalStr,CMode : String[3]; 49 | F : FIle; 50 | begin 51 | Str(x,XStr); 52 | Str(y,YStr); 53 | Str(x2,X2Str); 54 | Str(y2,Y2Str); 55 | Str(GetMaxColor+1,Cmode); 56 | Str(Pal,PalStr); 57 | 58 | Exec(wf.PrgName,filename+' '+wf.PrgFormat+ 59 | ' '+Xstr+' '+YStr+' '+x2Str+' '+Y2Str+' '+PalStr); 60 | Error:=DosError; 61 | if Error <> 0 then 62 | begin 63 | ReadCustom:=2000+Error; 64 | Exit; 65 | end; 66 | 67 | Error:=DosExitCode; 68 | if Error <> 0 then 69 | begin 70 | ReadCustom:=3000+Error; 71 | Exit; 72 | end; 73 | 74 | Error:=ReadRaw(x,y,x2,y2,pal,'RM$$.RAW'); 75 | {$I-} 76 | Assign(F,'RM$$.RAW'); 77 | Erase(F); 78 | Error:=IORESULT; 79 | {$I+} 80 | ReadCustom:=Error; 81 | end; 82 | 83 | begin 84 | end. -------------------------------------------------------------------------------- /RM/RWICO.PAS: -------------------------------------------------------------------------------- 1 | Unit RWico; 2 | Interface 3 | Function ReadIco(x,y,x2,y2 : word;filename : String) : Word; 4 | Function WriteIco(x,y,x2,y2 : word;Filename : String) : Word; 5 | 6 | Implementation 7 | uses Vars,dos; 8 | 9 | type 10 | IcoBuf = Array[1..32,1..32] of byte; 11 | 12 | const 13 | IcoColors : array[0..15] of word= (0,4,2,6,1,5,3,8,7,12,10,14,9,13,11,15); 14 | Unknown : array[1..104] of byte=( 15 | 40, 0, 0, 0, 32, 0, 0, 0, 64, 0, 0, 0, 1, 0, 16 | 4, 0, 0, 0, 0, 0,128, 2, 0, 0, 0, 0, 0, 0, 17 | 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18 | 0, 0, 0, 0,128, 0, 0,128, 0, 0, 0,128,128, 0, 19 | 128, 0, 0, 0,128, 0,128, 0,128,128, 0, 0,128,128, 20 | 128, 0,192,192,192, 0, 0, 0,255, 0, 0,255, 0, 0, 21 | 0,255,255, 0,255, 0, 0, 0,255, 0,255, 0,255,255, 22 | 0, 0,255,255,255, 0); 23 | 24 | Type 25 | tagICOHDR = Record 26 | icoReserved : Word; 27 | icoResourceType : word; 28 | icoResourceCount : word; 29 | end; 30 | 31 | tagICODSC = Record 32 | Width : byte; 33 | Height: byte; 34 | ColorCount : byte; 35 | Reserved1 : byte; 36 | reserved2 : word; 37 | Reserved3 : word; 38 | icoDIBSize: Longint; 39 | icoDIBOffset: Longint; 40 | end; 41 | 42 | var 43 | Ihead : tagICOHDR; 44 | Idesc : tagICODSC; 45 | IcoImgBuf : array [1..512] of byte; 46 | MSIcon : IcoBuf; 47 | f : file; 48 | 49 | Function ValidIco(fname : pathstr) : boolean; 50 | var 51 | mf : file; 52 | mhead : tagicohdr; 53 | mdesc : tagicodsc; 54 | Error : Word; 55 | begin 56 | {$I-} 57 | ValidIco:=true; 58 | Assign(mf,fname); 59 | Reset(mf,1); 60 | if filesize(mf)<>766 then 61 | begin 62 | ValidIco:=False; 63 | close(mf); 64 | exit; 65 | end; 66 | BlockRead(mf,mhead,sizeof(mhead)); 67 | BlockRead(mf,mdesc,sizeof(mdesc)); 68 | 69 | if (mdesc.Width <> 32) or (mdesc.Height <> 32) or (mdesc.ColorCount <>16) then 70 | begin 71 | ValidIco:=false; 72 | end; 73 | Close(mf); 74 | Error:=IORESULT; 75 | {$I+} 76 | end; 77 | 78 | Procedure ReadHead; 79 | begin 80 | {$I-} 81 | Blockread(f,ihead,sizeof(ihead)); 82 | {$I+} 83 | end; 84 | 85 | 86 | Procedure ReadDesc; 87 | begin 88 | {$I-} 89 | Blockread(f,idesc,sizeof(idesc)); 90 | {$I+} 91 | end; 92 | 93 | Procedure ReadImage; 94 | begin 95 | {$I-} 96 | seek(f,(filesize(f)-640)); 97 | BlockRead(f,IcoImgBuf,SizeOf(IcoImgBuf)); 98 | {$I+} 99 | end; 100 | 101 | Procedure WriteHead; 102 | begin 103 | Ihead.icoReserved :=0; 104 | Ihead.icoResourceType:=1; 105 | Ihead.icoResourceCount:=1; 106 | BlockWrite(f,ihead,sizeof(ihead)); 107 | end; 108 | 109 | Procedure WriteDesc; 110 | begin 111 | Idesc.Width:=32; 112 | Idesc.Height:=32; 113 | Idesc.ColorCount:=16; 114 | Idesc.Reserved1:=0; 115 | Idesc.Reserved2:=0; 116 | Idesc.Reserved3:=0; 117 | Idesc.icoDIBSize:=744; 118 | Idesc.icoDIBOffset:=22; 119 | BlockWrite(f,idesc,sizeof(idesc)); 120 | end; 121 | 122 | Procedure WriteUnknown; 123 | begin 124 | {$I-} 125 | BlockWrite(f,unknown,Sizeof(unknown)); 126 | {$I+} 127 | end; 128 | 129 | Procedure WriteImage; 130 | begin 131 | {$I-} 132 | BlockWrite(f,IcoImgBuf,SizeOf(icoImgBuf)); 133 | {$I+} 134 | end; 135 | 136 | Procedure WriteTail; 137 | Var 138 | empty : array[1..128] of byte; 139 | begin 140 | FillChar(empty,sizeof(empty),0); 141 | {$I-} 142 | BlockWrite(f,empty,sizeof(empty)); 143 | {$I+} 144 | end; 145 | 146 | 147 | 148 | Procedure UnpackColor(color:byte;Var c1,c2 : byte); 149 | begin 150 | c1:=color shr 4; 151 | c2:=color shl 4; 152 | c2:=c2 shr 4; 153 | end; 154 | 155 | Procedure PackToArray; 156 | Var 157 | w : word; 158 | h : word; 159 | i : word; 160 | PColors : byte; 161 | Color1 : byte; 162 | Color2 : byte; 163 | 164 | begin 165 | 166 | w:=1; 167 | h:=32; 168 | 169 | for i:=1 to 512 do 170 | begin 171 | Pcolors:=IcoImgBuf[i]; 172 | if w>31 then 173 | begin 174 | w:=1; 175 | dec(h); 176 | end; 177 | 178 | UnpackColor(Pcolors,Color1,Color2); 179 | MSIcon[w,h] :=IcoColors[Color1]; 180 | MSIcon[w+1,h] :=IcoColors[Color2]; 181 | inc(w,2); 182 | end; 183 | 184 | end; 185 | 186 | Function PackColors(c1,c2 : byte) : Byte; 187 | begin 188 | PackColors:=c1 shl 4 + c2; 189 | end; 190 | 191 | Procedure ArrayToPack; 192 | Var 193 | w : word; 194 | h : word; 195 | i : word; 196 | Color1 : byte; 197 | Color2 : byte; 198 | 199 | begin 200 | 201 | w:=1; 202 | h:=32; 203 | 204 | for i:=1 to 512 do 205 | begin 206 | if w>31 then 207 | begin 208 | w:=1; 209 | dec(h); 210 | end; 211 | 212 | Color1:=IcoColors[MSIcon[w,h]]; 213 | Color2:=IcoColors[MSIcon[w+1,h]]; 214 | IcoImgBuf[i] :=PackColors(Color1,Color2); 215 | inc(w,2); 216 | end; 217 | 218 | end; 219 | 220 | 221 | Function ReadIco(x,y,x2,y2 : word;filename : string) : Word; 222 | var 223 | Error : Word; 224 | i,j : word; 225 | width,height : word; 226 | begin 227 | {$I-} 228 | if ValidIco(filename) = false then 229 | begin 230 | readIco:=1000; 231 | exit; 232 | end; 233 | width:=x2-x+1; 234 | height:=y2-y+1; 235 | if width > 32 then width:=32; 236 | if height > 32 then height:=32; 237 | FillChar(msicon,sizeof(msicon),0); 238 | FillChar(Idesc,sizeof(idesc),0); 239 | Assign(f,filename); 240 | Reset(f,1); 241 | Error:=IOResult; 242 | if Error <>0 then 243 | begin 244 | ReadIco:=Error; 245 | exit; 246 | end; 247 | 248 | ReadHead; 249 | ReadDesc; 250 | ReadImage; 251 | Close(f); 252 | Error:=IOResult; 253 | if Error <>0 then 254 | begin 255 | ReadIco:=Error; 256 | exit; 257 | end; 258 | PackToArray; 259 | for i:=1 to width do 260 | begin 261 | for j:=1 to height do 262 | begin 263 | if (x+i-1 < 101) and (y+j-1 < 101) then 264 | begin 265 | IconImage[x+i-1,y+j-1]:=MSIcon[i,j]; 266 | end; 267 | end; 268 | end; 269 | 270 | ReadIco := IOResult; 271 | {$I+} 272 | end; 273 | 274 | 275 | Function WriteIco(x,y,x2,y2 : word;Filename : string) : Word; 276 | var 277 | i,j : word; 278 | width,height : word; 279 | begin 280 | {$I-} 281 | width:=x2-x+1; 282 | height:=y2-y+1; 283 | if width > 32 then width:=32; 284 | if height > 32 then height:=32; 285 | FillChar(MSicon,sizeof(msicon),1); 286 | for i:=1 to width do 287 | begin 288 | for j:=1 to height do 289 | begin 290 | if (i+x-1 < 101) and (j+y-1 < 101) then 291 | begin 292 | MSIcon[i,j]:=IconImage[x+i-1,y+j-1]; 293 | end; 294 | end; 295 | end; 296 | ArrayToPack; 297 | Assign(f,Filename); 298 | Rewrite(f,1); 299 | WriteHead; 300 | WriteDesc; 301 | WriteUnknown; 302 | WriteImage; 303 | WriteTail; 304 | Close(f); 305 | WriteIco :=IOResult; 306 | {$I+} 307 | end; 308 | 309 | begin 310 | end. -------------------------------------------------------------------------------- /RM/RWXGF.PAS: -------------------------------------------------------------------------------- 1 | Unit RWXgf; 2 | Interface 3 | uses dos,xgraph,graph,vars,core,Bits,bgiPal; 4 | Function WriteXgf(x,y,x2,y2,LanType : word;filename:string):word; 5 | Function ReadRaw(x,y,x2,y2,pal : Word;FileName : String) : Word; 6 | Function WriteRaw(x,y,x2,y2 : Word;FileName : String) : Word; 7 | Function ReadPAL(Filename : String) : Word; 8 | Function WritePAL(Filename : String) : Word; 9 | Function ReadICN(x,y,x2,y2 : Word;Filename : String) : Word; 10 | Implementation 11 | 12 | 13 | type 14 | linebuftype = array[0..1023] of byte; 15 | 16 | Procedure WriteXgfLine(Var F: File;xp,ln,width,bytesPerLine,LanType : word); 17 | var 18 | BitPlane1 : Word; 19 | BitPlane2 : Word; 20 | BitPlane3 : Word; 21 | BitPlane4 : Word; 22 | cp,cl,x, 23 | xoff,j : Word; 24 | mylinebuf : Linebuftype; 25 | Temp : Word; 26 | begin 27 | {$I-} 28 | Fillchar(mylinebuf,sizeof(mylinebuf),0); 29 | 30 | BitPlane1:=0; 31 | BitPlane2:=bytesPerLine; 32 | BitPlane3:=BytesPerLine*2; 33 | BitPlane4:=BytesPerLine*3; 34 | xoff:=xp; 35 | cp:=0; 36 | for x:=0 to bytesPerLine-1 do 37 | begin 38 | for j:=0 to 7 do 39 | begin 40 | cl:=IconImage[xoff+j,ln]; 41 | if biton(3,cl) then setbit((7-j),1,mylinebuf[BitPlane4+cp]); 42 | if biton(2,cl) then setbit((7-j),1,mylinebuf[BitPlane3+cp]); 43 | if biton(1,cl) then setbit((7-j),1,mylinebuf[BitPlane2+cp]); 44 | if biton(0,cl) then setbit((7-j),1,mylinebuf[BitPlane1+cp]); 45 | end; 46 | inc(cp); 47 | inc(xoff,8); 48 | end; 49 | 50 | If (LanType=TPLan) OR (LanType=TCLan) OR (LanType=PBLan) then 51 | begin 52 | For x:=0 to BitPlane2-1 do 53 | begin 54 | Temp:=myLineBuf[x]; 55 | mylineBuf[x]:=mylineBuf[x+BitPlane4]; 56 | mylineBuf[x+BitPlane4]:=Temp; 57 | Temp:=mylineBuf[x+BitPlane2]; 58 | mylineBuf[x+BitPlane2]:=mylineBuf[x+BitPlane3]; 59 | mylineBuf[x+BitPlane3]:=Temp; 60 | end; 61 | end; 62 | BlockWrite(F,mylinebuf,BytesPerLine*4); 63 | {$I+} 64 | end; 65 | 66 | 67 | Function WriteXgf(x,y,x2,y2,LanType : word;filename:string):word; 68 | Type 69 | XgfHead = Record 70 | Width : Word; 71 | Height : Word; 72 | End; 73 | Var 74 | mylinebuf : Linebuftype; 75 | myHead : XgfHead; 76 | mywidth : word; 77 | myheight : word; 78 | BPL : Word; 79 | F : File; 80 | Error : Word; 81 | J,I : Word; 82 | Temp : array[1..2] of char; 83 | begin 84 | {$I-} 85 | myWidth:=x2-x+1; 86 | myHeight:=y2-y+1; 87 | 88 | If (LanType=TPLan) OR (LanType=TCLan) then 89 | begin 90 | myhead.Width:=mywidth-1; 91 | myhead.Height:=myheight-1; 92 | end 93 | else 94 | begin 95 | If GetMaxColor=255 then 96 | begin 97 | myhead.Width:=mywidth SHL 3; 98 | end 99 | else 100 | begin 101 | myhead.Width:=mywidth; 102 | end; 103 | myhead.Height:=myheight; 104 | end; 105 | 106 | Assign(F,filename); 107 | Rewrite(F,1); 108 | BlockWrite(F,myhead,4); 109 | 110 | Error:=IOResult; 111 | if Error <> 0 then 112 | begin 113 | close(F); 114 | WriteXgf:=Error; 115 | exit; 116 | end; 117 | 118 | if GetMaxColor=15 then 119 | begin 120 | BPL:=(mywidth+7) div 8; 121 | For j:=0 to myheight-1 do 122 | begin 123 | WriteXgfline(F,x,y+j,mywidth,BPL,LanType); 124 | Error:=IOResult; 125 | if Error <> 0 then 126 | begin 127 | close(F); 128 | WriteXgf:=Error; 129 | exit; 130 | end; 131 | end; 132 | end 133 | else 134 | begin 135 | For j:=y to y2 do 136 | begin 137 | For i:=1 to myWidth do 138 | begin 139 | MyLineBuf[i-1]:=IconImage[i+x-1,j]; 140 | end; 141 | BlockWrite(F,MyLineBuf,myWidth); 142 | end; 143 | end; 144 | 145 | If (LanType = TPLan) OR (LanType=TCLan) then 146 | begin 147 | Temp:='RM'; 148 | BlockWrite(F,Temp,2); 149 | end; 150 | 151 | Close(F); 152 | WriteXgf:=IOResult; 153 | {$I+} 154 | end; 155 | 156 | Procedure mpTOsp(Var mPlane : Linebuftype;Var splane : Linebuftype; 157 | ImgOff2,ImgOff3,ImgOff4 : Word); 158 | Var 159 | i,j : Word; 160 | xpos : Word; 161 | Col : Word; 162 | begin 163 | xpos:=0; 164 | FillChar(splane,SizeOf(sPlane),0); 165 | For i:=0 to ImgOff2-1 do 166 | begin 167 | For j:=7 downto 0 do 168 | begin 169 | Col:=0; 170 | if biton(j,mPlane[i]) then 171 | begin 172 | Inc(Col,1); 173 | end; 174 | 175 | if biton(j,mPlane[i+ImgOff2]) then 176 | begin 177 | Inc(Col,2); 178 | end; 179 | 180 | if biton(j,mPlane[i+ImgOff3]) then 181 | begin 182 | Inc(Col,4); 183 | end; 184 | 185 | if biton(j,mPlane[i+ImgOff4]) then 186 | begin 187 | Inc(Col,8); 188 | end; 189 | 190 | Splane[xpos]:=Col; 191 | Inc(xpos); 192 | end; 193 | end; 194 | end; 195 | 196 | Function ReadICN(x,y,x2,y2 : Word;Filename : String) : Word; 197 | Type 198 | XgfHead = Record 199 | Width : Word; 200 | Height : Word; 201 | End; 202 | 203 | Var 204 | uline,sline : Linebuftype; 205 | myHead : XgfHead; 206 | mywidth : word; 207 | myheight : word; 208 | myFSize, 209 | FSize16, 210 | Fsize256 : Longint; 211 | BPL,BitPlane2,BitPlane3,BitPlane4 : Word; 212 | F : File; 213 | Error : Word; 214 | Temp : Word; 215 | J,I : Word; 216 | ICN16 : Boolean; 217 | 218 | begin 219 | {$I-} 220 | Assign(F,Filename); 221 | Reset(F,1); 222 | myFSize:=FileSize(F); 223 | Error:=IORESULT; 224 | If Error<>0 then 225 | begin 226 | ReadICN:=Error; 227 | exit; 228 | end; 229 | 230 | 231 | BlockRead(F,myHead,sizeof(myHead)); 232 | inc(myHead.width); 233 | inc(myHead.Height); 234 | 235 | myWidth:=x2-x+1; 236 | myheight:=y2-y+1; 237 | 238 | if myWidth > myHead.width then myWidth:=myHead.width; 239 | if myHeight > myHead.Height then myHeight:=myHead.Height; 240 | 241 | FSize16:=((myHead.width+7) div 8) * 4 * myhead.height+6; 242 | FSize256:=myHead.width * myhead.height+6; 243 | 244 | If myFSize=Fsize16 then 245 | begin 246 | ICN16:=TRUE; 247 | BPL:=((myHead.width+7) div 8) * 4; 248 | BitPlane2:=(BPL SHR 2); 249 | BitPlane3:=(BPL SHR 1); 250 | BitPlane4:=(BPL SHR 2) * 3; 251 | end 252 | else if myFSize=Fsize256 then 253 | begin 254 | ICN16:=FALSE; 255 | BPL:=LongInt(myHead.width) 256 | end 257 | else 258 | begin 259 | ReadICN:=1000; 260 | Close(F); 261 | Error:=IORESULT; 262 | exit; 263 | end; 264 | 265 | For j:=1 to myheight do 266 | begin 267 | If ICN16 then 268 | begin 269 | BlockRead(F,uline,BPL); 270 | For I:=0 to BitPlane2-1 do 271 | begin 272 | Temp:=Uline[I]; 273 | Uline[I]:=Uline[I+BitPlane4]; 274 | Uline[I+BitPlane4]:=Temp; 275 | Temp:=Uline[I+BitPlane2]; 276 | Uline[I+BitPlane2]:=Uline[I+BitPlane3]; 277 | Uline[I+BitPlane3]:=Temp; 278 | end; 279 | mpToSp(uline,sline,BitPlane2,BitPlane3,BitPlane4); 280 | end 281 | else 282 | begin 283 | BlockRead(F,sline,BPL); 284 | end; 285 | 286 | For i:=1 to myWidth do 287 | begin 288 | IconImage[x+i-1,y+j-1]:=sline[i-1]; 289 | end; 290 | 291 | end; 292 | 293 | if (ICN16=FALSE) AND (GetMAxColor=15) then 294 | begin 295 | ReduceTo16; 296 | end; 297 | Close(F); 298 | Error:=IORESULT; 299 | ReadICN:=Error; 300 | {$I+} 301 | end; 302 | 303 | 304 | 305 | 306 | Function WriteRaw(x,y,x2,y2 : Word;FileName : String) : Word; 307 | Var 308 | Error,i ,j : Word; 309 | F : File; 310 | Width,Height,Colors : Word; 311 | Tbuf : array[1..100] of Byte; 312 | myPal : PaletteT; 313 | begin 314 | Width:=x2-x+1; 315 | Height:=y2-y+1; 316 | Colors:=GetMaxColor+1; 317 | 318 | GrabPaletteList(myPal,Colors); 319 | 320 | {$I-} 321 | Assign(F,FileName); 322 | Rewrite(F,1); 323 | BlockWrite(F,Width,2); 324 | BlockWrite(F,Height,2); 325 | BlockWrite(F,Colors,2); 326 | 327 | BlockWrite(F,myPal,Colors*3); 328 | 329 | For j:=y to y2 do 330 | begin 331 | For i:=1 to Width do 332 | begin 333 | Tbuf[i]:=IconImage[x+i-1,j]; 334 | end; 335 | BlockWrite(F,TBuf,Width); 336 | Error:=IORESULT; 337 | If Error<>0 then 338 | begin 339 | WriteRaw:=Error; 340 | Exit; 341 | end; 342 | end; 343 | 344 | Close(F); 345 | Error:=IORESULT; 346 | WriteRaw:=Error; 347 | {$I+} 348 | end; 349 | 350 | Function ReadRaw(x,y,x2,y2,pal : Word;FileName : String) : Word; 351 | Var 352 | Error,i ,j : Word; 353 | F : File; 354 | Width,Height,Colors : Word; 355 | myWidth,myHeight : Word; 356 | Fcol : Byte; 357 | Tbuf : LineBufType; 358 | myPal : PaletteT; 359 | size,fsize : LongInt; 360 | begin 361 | myWidth:=x2-x+1; 362 | myHeight:=y2-y+1; 363 | {$I-} 364 | Assign(F,FileName); 365 | Reset(F,1); 366 | Error:=IORESULT; 367 | if Error <>0 then 368 | begin 369 | ReadRaw:=Error; 370 | Exit; 371 | end; 372 | 373 | fsize:=FileSize(F); 374 | 375 | BlockRead(F,Width,2); 376 | BlockRead(F,Height,2); 377 | BlockRead(F,Colors,2); 378 | 379 | size:=LongInt(Width)*LongInt(Height)+LongInt(Colors*3)+6; 380 | if size<>fsize then 381 | begin 382 | Close(f); 383 | ReadRaw:=1000; 384 | Error:=IORESULT; 385 | Exit; 386 | end; 387 | If Colors > 0 Then 388 | begin 389 | BlockRead(F,myPal,Colors*3); 390 | end; 391 | If myHeight > Height then myHeight:=Height; 392 | if myWidth > Width then myWidth:=Width; 393 | For j:=1 to myHeight do 394 | begin 395 | BlockRead(F,TBuf,Width); 396 | Error:=IORESULT; 397 | If Error<>0 then 398 | begin 399 | ReadRaw:=Error; 400 | Exit; 401 | end; 402 | For i:=1 to myWidth do 403 | begin 404 | IconImage[x+i-1,y+j-1]:=Tbuf[i-1]; 405 | end; 406 | end; 407 | Close(F); 408 | If (GetMaxColor=15) AND (Colors>16) then 409 | begin 410 | ReduceTo16; 411 | end; 412 | if Colors > (GetMaxColor+1) then Colors:=GetMaxColor+1; 413 | If Pal=1 then 414 | begin 415 | If Colors > 0 Then SetPaletteList(myPal,Colors); 416 | end; 417 | Error:=IORESULT; 418 | ReadRaw:=Error; 419 | {$I+} 420 | end; 421 | 422 | 423 | Function WritePAL(FileName : String): Word; 424 | Var 425 | F : File; 426 | myPal : PaletteT; 427 | Colors : Word; 428 | Error : Word; 429 | begin 430 | {$I-} 431 | Colors:=GetMaxColor+1; 432 | GrabPaletteList(myPal,Colors); 433 | Assign(F,FileName); 434 | Rewrite(F,1); 435 | BlockWrite(F,myPAL,Colors*3); 436 | Close(F); 437 | Error:=IORESULT; 438 | WritePAL:=Error; 439 | {$I+} 440 | end; 441 | 442 | Function ReadPAL(Filename : String) : Word; 443 | Var 444 | F : File; 445 | Fsize : LongInt; 446 | Colors : word; 447 | Error : Word; 448 | myPal : PaletteT; 449 | begin 450 | Colors:=GetMaxCOlor+1; 451 | Assign(F,FileName); 452 | Reset(F,1); 453 | Fsize:=FIleSize(F); 454 | If (Fsize<>48) AND (Fsize<>768) then 455 | begin 456 | ReadPAL:=1000; 457 | Exit; 458 | end; 459 | BlockRead(F,myPAL,Fsize); 460 | Close(F); 461 | Error:=IORESULT; 462 | ReadPAl:=Error; 463 | If Error = 0 then 464 | begin 465 | If Colors > (Fsize div 3) then 466 | begin 467 | Colors:=(Fsize div 3); 468 | end; 469 | SetPaletteList(myPal,Colors); 470 | end; 471 | end; 472 | 473 | begin 474 | end. -------------------------------------------------------------------------------- /RM/SCREEN.PAS: -------------------------------------------------------------------------------- 1 | 2 | Unit Screen; 3 | Interface 4 | Procedure TogleMode; 5 | Function SetSVGA16(Mode : Word) : Boolean; 6 | Function SetSVGA256(Mode :Word) : Boolean; 7 | Procedure RedrawImage; 8 | Implementation 9 | uses graph,Vars,core,Messages,Panel,bgiMouse,bgiPal; 10 | 11 | procedure Svga16; external; 12 | {$L SVGA16.OBJ } 13 | 14 | 15 | Procedure Svga256 ;external; 16 | {$L SVGA256.OBJ} 17 | 18 | 19 | (* 20 | procedure Svga16; external; 21 | {$L EGAVGA.OBJ } 22 | *) 23 | 24 | {$F+} 25 | Function DetectSVGA256 : integer; 26 | begin 27 | DetectSVGA256 :=2; 28 | end; 29 | {$F-} 30 | 31 | {$F+} 32 | Function DetectSVGA16 : integer; 33 | begin 34 | DetectSVGA16 :=3; 35 | end; 36 | {$F-} 37 | 38 | 39 | Function SetsVGA256(Mode : Word) : Boolean; 40 | Var 41 | Error : Word; 42 | gd,gm : Integer; 43 | begin 44 | SetsVga256:=TRUE; 45 | 46 | GD :=InstallUserDriver('svga256',@detectsvga256); 47 | GM :=Mode; 48 | 49 | Initgraph(gd,gm,''); 50 | If GraphResult <> 0 then 51 | begin 52 | SetsVGA256:=FALSE; 53 | end; 54 | end; 55 | 56 | 57 | Function SetSVGA16(Mode : Word) : Boolean; 58 | Var 59 | gd,gm : Integer; 60 | begin 61 | GD:=InstallUserDriver('svga16',@detectsvga16); 62 | GM:=Mode; 63 | 64 | Initgraph(gd,gm,''); 65 | If GraphResult <> 0 then 66 | begin 67 | SetSVGA16:=FALSE; 68 | end; 69 | end; 70 | 71 | 72 | 73 | (* 74 | Function SetVGA16(Mode : Word) : Boolean; 75 | var 76 | gd,gm : Integer; 77 | begin 78 | IF RegisterBGIDriver(@EGAVGADriverProc) < 0 then 79 | begin 80 | Writeln('Could not load video driver.'); 81 | halt(1); 82 | end; 83 | 84 | DetectGraph(gd,gm); 85 | if gd=VGA then 86 | begin 87 | gm:=Mode; 88 | initgraph(gd,gm,''); 89 | end 90 | else 91 | begin 92 | SetVGA16:=false; 93 | end; 94 | 95 | end; 96 | 97 | *) 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | Procedure TogleMode; 108 | Var 109 | myPal : PaletteT; 110 | begin 111 | GrabPaletteList(myPal,256); 112 | MouseHide; 113 | If GetMaxColor = 15 then 114 | begin 115 | ClearDevice; 116 | CloseGraph; 117 | if setsvga256(2)=False then 118 | begin 119 | if SetSVga16(3) then 120 | begin 121 | SetPaletteList(myPal,16); 122 | MouseMode(1); 123 | MouseShow; 124 | InfoMessage(200,175, 125 | {$IFDEF RMP} 126 | 'Raster Master cannot set', 127 | {$ELSE} 128 | 'MagniPaint cannot set', 129 | {$ENDIF} 130 | 'the 640X480X256 mode on', 131 | 'your SVGA card.'); 132 | MouseHide; 133 | end; 134 | end 135 | else 136 | begin 137 | SetPaletteList(myPal,256); 138 | MouseMode(2); 139 | end; 140 | end 141 | else if GetMaxColor=255 then 142 | begin 143 | ClearDevice; 144 | CloseGraph; 145 | ReduceTo16; 146 | if NColor > 15 then NColor:=White; 147 | if SetSVga16(3) then 148 | begin 149 | SetPaletteList(myPal,16); 150 | MouseMode(1); 151 | end 152 | end; 153 | 154 | end; 155 | 156 | Procedure RedrawImage; 157 | var 158 | i,j,Back : Word; 159 | begin 160 | Back:=MostColors; 161 | For i:=1 to 100 do 162 | begin 163 | For j:=1 to 100 do 164 | begin 165 | if IconImage[i,j] <> Back then 166 | begin 167 | PutPixel(ActualBox_x+i,ActualBox_y+j,IconImage[i,j]); 168 | end; 169 | end; 170 | end; 171 | 172 | DrawFullIconImage(1,1,MaxWH,MaxWH); 173 | end; 174 | 175 | 176 | begin 177 | end. 178 | -------------------------------------------------------------------------------- /RM/SVGA16.BGI: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RetroNick2020/raster-master-dos/51aa355531856ace663ac7eb4b65d02a39230bb7/RM/SVGA16.BGI -------------------------------------------------------------------------------- /RM/SVGA16.OBJ: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RetroNick2020/raster-master-dos/51aa355531856ace663ac7eb4b65d02a39230bb7/RM/SVGA16.OBJ -------------------------------------------------------------------------------- /RM/SVGA256.BGI: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RetroNick2020/raster-master-dos/51aa355531856ace663ac7eb4b65d02a39230bb7/RM/SVGA256.BGI -------------------------------------------------------------------------------- /RM/SVGA256.OBJ: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RetroNick2020/raster-master-dos/51aa355531856ace663ac7eb4b65d02a39230bb7/RM/SVGA256.OBJ -------------------------------------------------------------------------------- /RM/VARS.PAS: -------------------------------------------------------------------------------- 1 | {$I RM.INC} 2 | Unit Vars; 3 | InterFace 4 | Uses Dos,Graph; 5 | 6 | 7 | Const 8 | 9 | CompanyName = 'RetroNick'; 10 | ProgramName = 'Raster Master v3.8'; 11 | CopyRight1 = '(c) Copyright 1991-2022 By '+CompanyName+'.'; 12 | CopyRight2 = 'All Rights Reserved.'; 13 | GitHub1 = 'Get source and latest version from github:'; 14 | GitHub2 = 'https://github.com/RetroNick2020'; 15 | 16 | TPLan = 1; 17 | TCLan = 2; 18 | QCLan = 3; 19 | QBLan = 4; 20 | PBLan = 5; 21 | GWLan = 6; 22 | 23 | Binary2 = 1; 24 | Binary4 = 2; 25 | Binary16 = 3; 26 | Binary256 = 4; 27 | 28 | Source2 = 5; 29 | Source4 = 6; 30 | Source16 = 7; 31 | Source256 = 8; 32 | 33 | SPRBinary = 9; 34 | SPRSource = 10; 35 | 36 | PPRBinary = 11; 37 | PPRSource = 12; 38 | 39 | TEGLText = 13; 40 | 41 | PALSource = 14; 42 | Type 43 | IcoBuf = Array[1..100,1..100] of byte; 44 | 45 | FormatRec = Record 46 | PrgName : String[12]; 47 | PrgPat : String[3]; 48 | PrgRW : String[2]; 49 | PrgFormat : String[3]; 50 | PrgDis : String[20]; 51 | end; 52 | 53 | 54 | 55 | Var 56 | RMBox_x : Word; 57 | RMBox_y : Word; 58 | ToolBox_x,ToolBox_y : Word; 59 | ColorBox_x,ColorBox_y : Word; 60 | GridBox_x,GridBox_y : Word; 61 | ActualBox_x,Actualbox_y : Word; 62 | HScrollerBox_y : Word; 63 | HSCrollerBox_x : word; 64 | VScrollerBox_y : Word; 65 | VSCrollerBox_x : word; 66 | GridLine : Word; 67 | Tool : Word; 68 | NColor : Word; 69 | ColorOff : Word; 70 | IconImage : IcoBuf; 71 | UndoImage : IcoBuf; 72 | TempImage : IcoBuf; 73 | Rmode : Word; 74 | MaxWH : Word; 75 | CellH : Word; 76 | CellW : Word; 77 | Xoff : Word; 78 | Yoff : Word; 79 | RFtype : Word; 80 | WFtype : Word; 81 | RFrec : FormatRec; 82 | Wfrec : FormatRec; 83 | Cpath : String; 84 | DPath : String; 85 | (* gd,gm : Integer;*) 86 | LanType : Word; 87 | 88 | Implementation 89 | 90 | 91 | Procedure GetPath; 92 | var 93 | n : nameStr; 94 | d : dirStr; 95 | e : extStr; 96 | BEGIN 97 | fsplit(ParamStr(0),d,n,e); 98 | Dpath:=d; 99 | If POS('\',Dpath) =Length(Dpath) then 100 | begin 101 | Delete(Dpath,Length(Dpath),1); 102 | end; 103 | end; 104 | 105 | begin 106 | (* 107 | {$IFDEF RMP} 108 | Verify; 109 | {$ENDIF} 110 | *) 111 | Rmode :=2; (* 1) 25 X 25 2) 50 X 50 3) 100 x 100 *) 112 | MaxWH :=50; 113 | CellH :=8; 114 | CellW :=10; 115 | Xoff :=0; 116 | Yoff :=0; 117 | GridLine:=0; 118 | Ncolor :=White; 119 | ColorOff:=0; 120 | Tool :=6; 121 | FillChar(IconImage,sizeof(IconImage),Blue); 122 | FillChar(TempImage,sizeof(TempImage),Blue); 123 | FillChar(UndoImage,sizeof(UndoImage),Blue); 124 | 125 | RFtype:=1; 126 | WFtype:=1; 127 | Rfrec.PrgPat:='PCX'; 128 | Wfrec.PrgPat:='PCX'; 129 | 130 | GetPath; 131 | cpath :='*.PCX'; 132 | cpath :=FExpand(cpath); 133 | end. 134 | 135 | -------------------------------------------------------------------------------- /RM/WCON.PAS: -------------------------------------------------------------------------------- 1 | Unit Wcon; 2 | Interface 3 | uses vars,dos,Graph,rwXGF,WPRF,Xgf2src; 4 | Function WriteDat(x,y,x2,y2,myFormat,LanType : word; filename : string) : word; 5 | 6 | Implementation 7 | 8 | Function WriteDat(x,y,x2,y2,myFormat,LanType : word;filename:string):word; 9 | Var 10 | mywidth : word; 11 | myheight: word; 12 | F : File; 13 | Error : Word; 14 | begin 15 | {$I+} 16 | myWidth:=x2-x+1; 17 | myHeight:=y2-y+1; 18 | 19 | If myFormat=SPRSource then 20 | begin 21 | error:=WriteSPR(x,y,x2,y2,'$$$$.tmp'); 22 | end 23 | else if myFormat=PPRSource then 24 | begin 25 | error:=WritePPR(x,y,x2,y2,'$$$$.tmp'); 26 | end 27 | else if myFormat=PALSource then 28 | begin 29 | error:=WritePAL('$$$$.tmp'); 30 | end 31 | else 32 | begin 33 | error:=writeXgf(x,y,x2,y2,LanType,'$$$$.tmp'); 34 | end; 35 | 36 | if Error<>0 then 37 | begin 38 | WriteDat:=Error; 39 | exit; 40 | end; 41 | 42 | error:=XgfToSrc('$$$$.tmp',filename,myWidth,myHeight,GetMaxColor+1,myFormat,Lantype); 43 | Assign(f,'$$$$.tmp'); 44 | Erase(F); 45 | 46 | WriteDAT:=error; 47 | Error:=IORESULT; 48 | 49 | {$I+} 50 | end; 51 | 52 | 53 | 54 | begin 55 | end. -------------------------------------------------------------------------------- /RM/WDEF.PAS: -------------------------------------------------------------------------------- 1 | Unit WDEF; 2 | Interface 3 | uses dos,graph,vars,rmstrg; 4 | Function WriteDef(x,y,x2,y2 : word;filename : String) : word; 5 | Implementation 6 | 7 | 8 | 9 | Function WriteDef(x,y,x2,y2 : word;Filename : String) : word; 10 | var 11 | f : text; 12 | error : word; 13 | i,j : word; 14 | HexStr : String; 15 | HexP : Word; 16 | begin 17 | If GetMaxColor= 15 then 18 | begin 19 | HexP:=1; 20 | end 21 | else 22 | begin 23 | HexP:=2; 24 | end; 25 | 26 | {$I-} 27 | Assign(f,filename); 28 | Rewrite(f); 29 | error:=IOResult; 30 | if error <>0 then 31 | begin 32 | WriteDef:=Error; 33 | exit; 34 | end; 35 | for j:=y to y2 do 36 | begin 37 | for i:=x to x2 do 38 | begin 39 | HexStr:=StrHex(IconImage[i,j],HexP); 40 | Write(f,HexStr); 41 | Error:=IORESULT; 42 | If Error <> 0 THen 43 | begin 44 | WriteDef:=Error; 45 | Exit; 46 | end; 47 | end; 48 | Writeln(f); 49 | end; 50 | close(f); 51 | Error:=IORESULT; 52 | WriteDef:=Error; 53 | {$I+} 54 | end; 55 | 56 | begin 57 | end. -------------------------------------------------------------------------------- /RM/WMASK.PAS: -------------------------------------------------------------------------------- 1 | Unit WMask; 2 | Interface 3 | uses Dos,rmStrg,Vars,Bits,xgf2src; 4 | Function WriteMouseMask(x,y,x2,y2,LanType: Word;Filename : String) : Word; 5 | 6 | Implementation 7 | 8 | Function WriteMouseMask(x,y,x2,y2,LanType: Word;Filename : String) : Word; 9 | Var 10 | i,j : Word; 11 | Width,Height : Word; 12 | Solid,Holow,TImage : String[16]; 13 | Count,Error : Word; 14 | F : Text; 15 | MouseName : String; 16 | Mpos : Word; 17 | MouseImage : Array[1..32] of String[16]; 18 | TextImage : Array[1..16] of String[16]; 19 | Temp : Word; 20 | Code : Integer; 21 | 22 | begin 23 | FileNameToImageName(FileName,MouseName); 24 | Width:=x2-x+1; 25 | Height:=y2-y+1; 26 | If Width > 16 then Width:=16; 27 | if Height > 16 then Height:=16; 28 | Count:=0; 29 | 30 | 31 | For j:=y to y+15 do 32 | begin 33 | Solid :='1111111111111111'; 34 | Holow :='0000000000000000'; 35 | TImage:=' '; 36 | If (j <= y2) then 37 | begin 38 | For i:=1 to Width do 39 | begin 40 | If IconImage[i+x-1,j] = 0 then 41 | begin 42 | Solid[i]:='0'; 43 | Holow[i]:='0'; 44 | TImage[i]:='*'; 45 | end 46 | else if IconImage[i+x-1,j]=15 then 47 | begin 48 | Solid[i]:='0'; 49 | Holow[i]:='1'; 50 | TImage[i]:='#'; 51 | end 52 | else if IconImage[i+x-1,j]=1 then 53 | begin 54 | Solid[i]:='1'; 55 | Holow[i]:='0'; 56 | Timage[i]:=' '; 57 | end 58 | else 59 | begin 60 | Solid[i]:='1'; 61 | Holow[i]:='1'; 62 | TImage[i]:='X'; 63 | end; 64 | end; 65 | end; 66 | Inc(Count); 67 | Temp:=ValBin(Solid,Code); 68 | MouseImage[Count]:=StrHex(Temp,4); 69 | Temp:=ValBin(Holow,Code); 70 | MouseImage[Count+16]:=StrHex(Temp,4); 71 | TextImage[Count]:=TImage; 72 | end; 73 | 74 | 75 | {$I-} 76 | Assign(F,FileName); 77 | Rewrite(F); 78 | 79 | Case LanType Of TPLan:WriteLn(F,'(*'); 80 | TCLan:WriteLn(F,'/*'); 81 | end; 82 | 83 | For i:=1 to 16 do 84 | begin 85 | if LanType=QBLan then Write(F,#39#32); 86 | WriteLn(F,TextImage[i]); 87 | end; 88 | 89 | 90 | Case LanType Of TPLan:begin 91 | WriteLn(F,'Mouse Cursor Image *)'); 92 | WriteLn(F); 93 | WriteLn(F,MouseName,' : Array[1..32] Of Word = ('); 94 | Write(F,' ':5); 95 | End; 96 | TCLan:begin 97 | WriteLn(F,'Mouse Cursor Image */'); 98 | WriteLn(F); 99 | WriteLn(F,'int ',MouseName,'[] = {'); 100 | Write(F,' ':5); 101 | End; 102 | 103 | QBLan:begin 104 | WriteLn(F,#39,' Mouse Cursor Image'); 105 | WriteLn(F,#39,' ',MouseName); 106 | WriteLn(F); 107 | Write(F,'DATA '); 108 | End; 109 | 110 | 111 | End; 112 | 113 | Count:=0; 114 | For i:=1 to 31 do 115 | begin 116 | Case LanType of TPLan: Write(F,'$',MouseImage[i],','); 117 | TCLan: Write(F,'0x',MouseImage[i],','); 118 | QBLan:begin 119 | Write(F,'&H',MouseImage[i]); 120 | if (i mod 8) <> 0 then write(F,','); 121 | End; 122 | end; 123 | Inc(Count); 124 | If Count=8 then 125 | begin 126 | WriteLn(F); 127 | if LanType=QBLan then 128 | begin 129 | Write(F,'DATA '); 130 | end 131 | else 132 | begin 133 | Write(F,' ':5); 134 | end; 135 | Count:=0; 136 | end; 137 | End; 138 | Case Lantype of TPLan: WriteLn(F,'$',MouseImage[32],');'); 139 | TCLan: WriteLn(F,'0x',MouseImage[32],'};'); 140 | QBLan: WriteLn(F,'&H',MouseImage[32]); 141 | End; 142 | WriteLn(F); 143 | Close(F); 144 | Error:=IORESULT; 145 | WriteMouseMask:=Error; 146 | 147 | end; 148 | 149 | 150 | begin 151 | end. -------------------------------------------------------------------------------- /RM/WPRF.PAS: -------------------------------------------------------------------------------- 1 | Unit WPRF; 2 | Interface 3 | uses vars,dos,graph; 4 | Function WritePPR(x,y,x2,y2 : word; filename : string) : word; 5 | Function WriteSPR(x,y,x2,y2 : word; filename : string) : word; 6 | 7 | Implementation 8 | 9 | Function WritePPR(x,y,x2,y2 : word;filename:string):word; 10 | Var 11 | f : file; 12 | rc :byte; 13 | i,j : word; 14 | col : byte; 15 | lastcol : byte; 16 | myWidth : word; 17 | myHeight: word; 18 | nc : byte; 19 | cl : Array[1..3] of byte; 20 | error : word; 21 | myPprHeader : Array[1..24] of byte; 22 | begin 23 | {$I-} 24 | myWidth:=x2-x+1; 25 | myHeight:=y2-y+1; 26 | 27 | Fillchar(myPprHeader,24,0); 28 | 29 | myPprHeader[1]:=ORD('P'); 30 | myPprHeader[4]:=ORD('P'); 31 | myPprHeader[7]:=ORD('R'); 32 | 33 | myPprHeader[10]:=HI(myWidth); 34 | myPprHeader[13]:=LO(myWidth); 35 | 36 | myPprHeader[16]:=HI(myHeight); 37 | myPprHeader[19]:=LO(myHeight); 38 | 39 | myPPrHeader[22]:=4; 40 | 41 | assign(F,filename); 42 | rewrite(f,1); 43 | 44 | BlockWrite(F,myPprHeader,24); 45 | 46 | 47 | nc:=0; 48 | rc:=0; 49 | fillchar(cl,3,0); 50 | 51 | for j:=y2 downto y do 52 | begin 53 | for i:=x to x2 do 54 | begin 55 | col:=IconImage[i,j]; 56 | inc(rc); 57 | if rc=1 then 58 | begin 59 | Lastcol:=col; 60 | end 61 | else if col<>lastcol then 62 | begin 63 | inc(nc); 64 | if nc=1 then 65 | begin 66 | cl[1]:=(lastcol shl 4); 67 | cl[2]:=rc-1; 68 | end 69 | else if nc=2 then 70 | begin 71 | inc(cl[1],lastcol); 72 | cl[3]:=rc-1; 73 | nc:=0; 74 | Blockwrite(f,cl[1],3); 75 | fillchar(cl,3,0); 76 | end; 77 | rc:=1; 78 | lastcol:=col; 79 | end 80 | else if rc=255 then 81 | begin 82 | inc(nc); 83 | if nc=1 then 84 | begin 85 | cl[1]:=(col shl 4); 86 | cl[2]:=rc; 87 | end 88 | else if nc=2 then 89 | begin 90 | inc(cl[1],col); 91 | cl[3]:=rc; 92 | nc:=0; 93 | blockwrite(f,cl[1],3); 94 | fillchar(cl,3,0); 95 | end; 96 | rc:=0; 97 | end; 98 | end; 99 | 100 | 101 | error:=ioresult; 102 | if error<>0 then 103 | begin 104 | close(f); 105 | erase(f); 106 | WritePPR:=error; 107 | exit; 108 | end; 109 | 110 | 111 | end; 112 | if rc>0 then 113 | begin 114 | if nc=0 then 115 | begin 116 | cl[1]:=(col shl 4); 117 | cl[2]:=rc; 118 | cl[3]:=0; 119 | end 120 | else 121 | begin 122 | inc(cl[1],col); 123 | cl[3]:=rc; 124 | end; 125 | Blockwrite(f,cl,3); 126 | end; 127 | close(F); 128 | error:=IOresult; 129 | WritePPR:=error; 130 | {$I+} 131 | end; 132 | 133 | 134 | Function WriteSPR(x,y,x2,y2 : word;filename:string):word; 135 | Var 136 | f: file; 137 | rc:byte; 138 | i,j : word; 139 | col : byte; 140 | lastcol:byte; 141 | myWidth:word; 142 | myHeight:word; 143 | 144 | error : word; 145 | mySprHeader : Array[1..16] of byte; 146 | begin 147 | {$I-} 148 | 149 | myWidth:=x2-x+1; 150 | myHeight:=y2-y+1; 151 | 152 | Fillchar(mySprHeader,16,0); 153 | mySprHeader[1]:=ORD('S'); 154 | mySprHeader[3]:=ORD('P'); 155 | mySprHeader[5]:=ORD('R'); 156 | 157 | mySprHeader[7]:=HI(myWidth); 158 | mySprHeader[9]:=LO(myWidth); 159 | 160 | mySprHeader[11]:=HI(myHeight); 161 | mySprHeader[13]:=LO(myHeight); 162 | 163 | 164 | If GetMaxColor = 255 then 165 | begin 166 | mySprHeader[15]:=8; 167 | end 168 | else 169 | begin 170 | mySprHeader[15]:=4; 171 | end; 172 | assign(F,filename); 173 | rewrite(f,1); 174 | 175 | BlockWrite(F,mySprHeader,16); 176 | 177 | rc:=0; 178 | for j:=y2 downto y do 179 | begin 180 | for i:=x to x2 do 181 | begin 182 | col:=IconImage[i,j]; 183 | inc(rc); 184 | if rc=1 then 185 | begin 186 | Lastcol:=col; 187 | end 188 | else if col<>lastcol then 189 | begin 190 | Blockwrite(f,lastcol,1); 191 | dec(rc); 192 | Blockwrite(f,rc,1); 193 | rc:=1; 194 | lastcol:=col; 195 | end 196 | else if rc=255 then 197 | begin 198 | blockwrite(f,col,1); 199 | blockwrite(f,rc,1); 200 | rc:=0; 201 | end; 202 | end; 203 | 204 | error:=ioresult; 205 | if error<>0 then 206 | begin 207 | close(f); 208 | erase(f); 209 | WriteSPR:=error; 210 | exit; 211 | end; 212 | 213 | end; 214 | if rc>0 then 215 | begin 216 | blockwrite(f,col,1); 217 | blockwrite(f,rc,1); 218 | end; 219 | close(F); 220 | error:=ioresult; 221 | WriteSPR:=error; 222 | {$I+} 223 | end; 224 | 225 | begin 226 | end. -------------------------------------------------------------------------------- /RM/XGF2SRC.PAS: -------------------------------------------------------------------------------- 1 | Unit XGF2SRC; 2 | Interface 3 | Uses Dos,Vars; 4 | 5 | Function XgfToSrc(XgfFile,SrcFile:string;myWidth,myHeight,nColors,myformat,myComp:Word):word; 6 | Procedure FilenameToImageName(Var filename,Imagename : string); 7 | 8 | Implementation 9 | 10 | 11 | Procedure Byte2str(mybyte : byte;Var mystring :string); 12 | const 13 | hexa : array[0..15] of char=('0','1','2','3','4','5','6','7','8','9', 14 | 'A','B','C','D','E','F'); 15 | var 16 | h1,h2 : byte; 17 | begin 18 | h1:=mybyte shr 4; 19 | h2:=mybyte shl 4; 20 | h2:=h2 shr 4; 21 | mystring:=hexa[h1]+hexa[h2]; 22 | end; 23 | 24 | Procedure WriteHeaders(Var F : Text;myImageName : String; myWidth,myHeight,Ncolors, 25 | myComp, myFormat:Word;myfilesize : LongInt); 26 | Const 27 | xprForm : array[SprSource..PPRSource] of String = ('SPR','','PPR'); 28 | Var 29 | myRunCount : LongInt; 30 | begin 31 | {$I-} 32 | If myFormat = SPRSource then 33 | begin 34 | myRunCount:=myFileSize div 2; 35 | end 36 | else 37 | begin 38 | myRunCount:=(myFileSize div 3)*2; 39 | end; 40 | 41 | Case myFormat of Source2..Source256: 42 | begin 43 | Case myComp of TPLan: 44 | begin 45 | WriteLn(F,'(* Turbo Pascal, Width= ',myWidth, 46 | ' Height= ',myHeight,' Colors= ',Ncolors,' *)'); 47 | end; 48 | TCLan: 49 | begin 50 | Writeln(F,'/* Turbo C, Width= ',myWidth, 51 | ' Height= ',myHeight,' Colors= ',Ncolors,' */'); 52 | end; 53 | QCLan: 54 | begin 55 | Writeln(F,'/* QuickC, Width= ',myWidth, 56 | ' Height= ',myHeight,' Colors= ',Ncolors,' */'); 57 | end; 58 | QBLan: 59 | begin 60 | Writeln(F,#39,' QuickBASIC, Array Size= ',myFileSize div 2, 61 | ' Width= ',myWidth,' Height= ',myHeight,' Colors= ',Ncolors); 62 | 63 | Writeln(F,#39,' ',myImageName); 64 | end; 65 | PBLan: 66 | begin 67 | Writeln(F,#39,' PowerBASIC, Array Size= ',myFileSize div 2, 68 | ' Width= ',myWidth,' Height= ',myHeight,' Colors= ',Ncolors); 69 | Writeln(F,#39,' ',myImageName); 70 | end; 71 | GWLan: 72 | begin 73 | Writeln(F,'1000 ',#39,' ',myImageName); 74 | Writeln(F,'1010 ',#39,' GWBASIC, Array Size= ',myFileSize div 2, 75 | ' Width= ',myWidth,' Height= ',myHeight,' Colors= ',Ncolors); 76 | end; 77 | 78 | End; 79 | End; 80 | SPRSource,PPRSource: 81 | begin 82 | Case myComp of TPLan: 83 | begin 84 | Writeln(F,'(* Width= ',myWidth,' Height= ',myHeight, 85 | ' Colors= ',Ncolors,' Format= ',xprForm[myFormat],' RunCount= ',myRunCount,' *)'); 86 | end; 87 | TCLan,QCLan: 88 | begin 89 | Writeln(F,'/* Width= ',myWidth,' Height= ',myHeight, 90 | ' Colors= ',Ncolors,' Format= ',xprForm[myFormat],' RunCount= ',myRunCount,' */'); 91 | end; 92 | QBLan,PBLan: 93 | begin 94 | Writeln(F,#39,' ',myImageName); 95 | Writeln(F,#39,' Width= ',myWidth,' Height= ',myHeight,' Colors= ',Ncolors); 96 | Writeln(F,#39,' String Size= ',myFileSize,' Format= ',xprForm[myFormat],' RunCount= ',myRunCount) 97 | 98 | end; 99 | End; 100 | End; 101 | PALSource: 102 | begin 103 | Case myComp of TPLan: 104 | begin 105 | Writeln(F,'(* Pascal Palette Source, ',NColors,' Colors (RGB) *)'); 106 | end; 107 | TCLan,QCLan: 108 | begin 109 | Writeln(F,'/* C Palette Source, ',NColors,' Colors (RGB) */'); 110 | end; 111 | QBLan,PBLan: 112 | begin 113 | Writeln(F,#39,' BASIC Palette Source, ',NColors,' Colors (RGB)'); 114 | end; 115 | End; 116 | End; 117 | End; 118 | 119 | 120 | if myComp=GWLan then 121 | begin 122 | writeln(F,'1020 ',#39); 123 | end 124 | else 125 | begin 126 | Writeln(F); 127 | end; 128 | 129 | If myComp = TPlan then 130 | begin 131 | WriteLn(F,myImageName, ' : Array[1..',myFileSize,'] of Byte = ('); 132 | end 133 | Else if (myComp = QCLan) or (myComp = TCLan) then 134 | begin 135 | WriteLn(F,'char ',myImageName,'[',myFileSize,'] = {'); 136 | end; 137 | 138 | {$I+} 139 | end; 140 | 141 | 142 | Procedure FilenameToImageName(Var filename,Imagename : string); 143 | Var 144 | d : dirstr; 145 | n : namestr; 146 | e : extstr; 147 | i : Word; 148 | begin 149 | fsplit(filename,d,n,e); 150 | n[1]:=upcase(n[1]); 151 | if length(n) > 1 then 152 | begin 153 | for i:=2 to length(n) do 154 | begin 155 | case n[i] of 'A'..'Z':begin 156 | n[i]:=chr(ord(n[i])+32); 157 | end; 158 | end; 159 | end; 160 | end; 161 | ImageName:=n; 162 | end; 163 | 164 | 165 | Function XgfToSrc(XgfFile,SrcFile:string;myWidth,myHeight,nColors,myformat,myComp:Word):word; 166 | Type 167 | ImgBuf = array[1..60000] of byte; 168 | Var 169 | F : Text; 170 | f2 : file; 171 | Error : Word; 172 | i : LongInt; 173 | mybyte : integer; 174 | 175 | RunCount : longint; 176 | myImageName : String; 177 | NumRead : Longint; 178 | NumPerLine : Word; 179 | Counter : Word; 180 | NumToRead : LongInt; 181 | S,S2 : String; 182 | myWord : Word; 183 | myFileSize : LongInt; 184 | myPercent : Longint; 185 | myLineNumber : Word; 186 | myxprHeader:Array[1..24] of byte; 187 | myBuf : ^ImgBuf; 188 | 189 | begin 190 | {$I-} 191 | myLineNumber:=1040; 192 | FilenameToImagename(SrcFile,myImageName); 193 | Numread:=0; 194 | NumPerLine:=12; 195 | Case myComp of GWLan,PBLan,QBLan: begin 196 | if myFormat < SPRBinary then NumPerLine:=8; 197 | end; 198 | 199 | End; 200 | Counter:=0; 201 | Assign(F,Srcfile); 202 | Rewrite(F); 203 | 204 | 205 | Assign(F2,XgfFile); 206 | reset(F2,1); 207 | 208 | myFileSize:=FileSize(F2); 209 | Case myFormat of SPRSource:begin 210 | Dec(myFileSize,16); 211 | BlockRead(F2,myXprHeader,16); 212 | end; 213 | PPRSource:begin 214 | Dec(myFileSize,24); 215 | BlockRead(F2,myXprHeader,24); 216 | end; 217 | end; 218 | 219 | 220 | NumToRead:=myFilesize; 221 | 222 | (* 223 | Case myComp of QBLan,PBLan,GWLan: if myformat < SPRBinary then NumToRead:=myFileSize div 2; 224 | End; 225 | *) 226 | WriteHeaders(F,myImageName,myWidth,myHeight,nColors,myComp,myFormat,myFileSize); 227 | 228 | 229 | Case myComp of QBLan,PBLan: Write(F,'DATA '); 230 | GWLan: Write(F,'1030 DATA '); 231 | else 232 | Write(F,'':10); 233 | End; 234 | 235 | GetMem(myBuf,NumToRead); 236 | BlockRead(F2,myBuf^,NumToREad); 237 | NumRead:=0; 238 | i:=1; 239 | Repeat 240 | 241 | 242 | case myComp of TPlan: Write(F,'$'); 243 | GWLan,QBLan,PBLan: Write(F,'&H'); 244 | TCLan,QCLan: Write(F,'0x'); 245 | end; 246 | 247 | Case myComp of GWLan,QBLan,PBLan: 248 | begin 249 | If myFormat0 then 313 | begin 314 | close(f); 315 | close(f2); 316 | erase(f); 317 | FreeMem(myBuf,NumToRead); 318 | XgfToSrc:=error; 319 | Error:=IORESULT; 320 | exit; 321 | end; 322 | 323 | Until i > NumToRead; 324 | 325 | FreeMem(myBuf,NumToRead); 326 | 327 | Case myComp of QCLan,TCLan:writeln(F,'};'); 328 | TPLan:writeln(F,');'); 329 | End; 330 | Close(F); 331 | close(F2); 332 | 333 | if error<>0 then 334 | begin 335 | erase(f); 336 | end; 337 | XgfToSrc:=IOResult; 338 | {$I+} 339 | end; 340 | 341 | 342 | 343 | 344 | begin 345 | end. -------------------------------------------------------------------------------- /RM/XGRAPH.PAS: -------------------------------------------------------------------------------- 1 | Unit XGraph; (* some things to fix *) 2 | Interface 3 | uses graph; 4 | 5 | Function ImageSize(x,y,x2,y2 : longint) : LongInt; 6 | 7 | Implementation 8 | 9 | Function ImageSize(x,y,x2,y2 : longint) : LongInt; 10 | begin 11 | if GetMaxColor = 255 then 12 | begin 13 | ImageSize:=6+(x2-x+1)*(y2-y+1); 14 | end 15 | else 16 | begin 17 | ImageSize:=graph.ImageSize(x,y,x2,y2); 18 | end; 19 | end; 20 | 21 | begin 22 | end. -------------------------------------------------------------------------------- /RMCLIP/BGIEDIT.PAS: -------------------------------------------------------------------------------- 1 | Unit bgiEdit; 2 | Interface 3 | 4 | Procedure EditString(x,y,visibleColumns: Integer;Var cursorState: integer;BackColor, 5 | forColor,curColor, mouseState : Integer;Var msg : String); 6 | Implementation 7 | uses dos,crt,graph,keys,bgiMouse; 8 | 9 | Procedure EditString(x,y,visibleColumns: Integer;Var cursorState: integer;BackColor, 10 | forColor,curColor, mouseState : Integer;Var msg : String); 11 | 12 | Const 13 | FWidth = 8; 14 | FHeight = 9; 15 | flash : Boolean = True; 16 | var 17 | myKey : Word; 18 | tempString : String; 19 | offset : Integer; 20 | Pos : Integer; 21 | originalString : String; 22 | 23 | Procedure ShowCursor; 24 | begin 25 | SetFillStyle(SolidFill,curColor); 26 | Case cursorState of 0:begin 27 | Bar(x+(pos*FWidth)-FWidth,y,x+(pos*FWidth)-2,y+FHeight); 28 | if length(msg) >0 then 29 | begin 30 | Setcolor(backColor); 31 | OutTextXY(x+(pos*FWidth)-FWidth,y,msg[Pos+offset]); 32 | end; 33 | 34 | end; 35 | 1:begin 36 | Bar(x+(pos*FWidth)-FWidth,y+FHeight-1, 37 | x+(pos*FWidth)-2,y+FHeight); 38 | (* 39 | if length(msg) >0 then 40 | begin 41 | Setcolor(backColor); 42 | OutTextXY(x+(pos*FWidth)-FWidth,y,msg[Pos+offset]); 43 | end; 44 | *) 45 | end; 46 | end; 47 | 48 | end; 49 | 50 | Procedure HideCursor; 51 | begin 52 | SetFillStyle(SolidFill,backColor); 53 | Case cursorState of 0:begin 54 | Bar(x+(pos*FWidth)-FWidth, 55 | y,x+(pos*FWidth)-2, 56 | y+FHeight); 57 | Setcolor(forColor); 58 | OuttextXY(x+(pos*FWidth)-FWidth,y, 59 | msg[Pos+offset]); 60 | end; 61 | 1:begin 62 | Bar(x+(pos*FWidth)-FWidth, 63 | y+FHeight-1, 64 | x+(pos*FWidth)-2, 65 | y+FHeight); 66 | end; 67 | end; 68 | end; 69 | 70 | Procedure ClearEditBox; 71 | begin 72 | SetFillStyle(SolidFill,BackColor); 73 | Bar(x,y,x+(visibleColumns*FWidth)-2,y+FHeight); 74 | end; 75 | 76 | Procedure HomeKeyAction; 77 | begin 78 | if (pos+offset)<>1 then 79 | begin 80 | pos:=1; 81 | offset:=0; 82 | tempstring:=copy(msg,offset+1,visiblecolumns); 83 | 84 | if mouseState=1 then MouseHide; 85 | clearEditBox; 86 | Setcolor(forColor); 87 | OuttextXY(x,y,tempstring); 88 | showcursor; 89 | if mouseState=1 then MouseShow; 90 | 91 | end; 92 | end; 93 | 94 | Procedure EndKeyAction; 95 | begin 96 | if (pos+offset) <> length(msg) then 97 | begin 98 | if length(msg) > visibleColumns then 99 | begin 100 | pos:=visibleColumns; 101 | offset:=length(msg)-pos; 102 | end 103 | else 104 | begin 105 | pos:=length(msg); 106 | offset:=0; 107 | end; 108 | tempstring:=copy(msg,offset+1,visiblecolumns); 109 | 110 | if mouseState=1 then MouseHide; 111 | clearEditBox; 112 | Setcolor(forColor); 113 | OuttextXY(x,y,tempstring); 114 | showcursor; 115 | if mouseState=1 then MouseShow; 116 | end; 117 | end; 118 | 119 | Procedure LeftKeyAction; 120 | begin 121 | if (pos > 1) then 122 | begin 123 | if mouseState=1 then MouseHide; 124 | hidecursor; 125 | dec(pos); 126 | showcursor; 127 | if mouseState=1 then MouseShow; 128 | end 129 | else if ((pos=1) AND (offset>0)) then 130 | begin 131 | dec(offset); 132 | tempstring:=copy(msg,pos+offset,visibleColumns); 133 | if mouseState=1 then MouseHide; 134 | cleareditbox; 135 | Setcolor(forColor); 136 | OuttextXY(x,y,tempstring); 137 | showcursor; 138 | if mouseState=1 then MouseShow; 139 | end; 140 | end; 141 | 142 | Procedure RightKeyAction; 143 | begin 144 | if Length(msg)<>0 then 145 | begin 146 | if (pos < visibleColumns) then 147 | begin 148 | if length(msg) > (pos+offset) then 149 | begin 150 | if mouseState=1 then MouseHide; 151 | hidecursor; 152 | inc(pos); 153 | showcursor; 154 | if mouseState=1 then MouseShow; 155 | end; 156 | end 157 | else if ((pos+offset)< Length(msg)) then 158 | begin 159 | inc(offset); 160 | tempstring:=copy(msg,offset+1,visiblecolumns); 161 | if mouseState=1 then MouseHide; 162 | clearEditBox; 163 | Setcolor(forColor); 164 | OutTextXY(x,y,tempstring); 165 | showcursor; 166 | if mouseState=1 then MouseShow; 167 | end; 168 | end; 169 | end; 170 | 171 | Procedure DelKeyAction; 172 | begin 173 | if length(msg)<>0 then 174 | begin 175 | delete(msg,pos+offset,1); 176 | if (pos+offset) > length(msg) then 177 | begin 178 | if offset > 0 then 179 | begin 180 | dec(offset); 181 | end 182 | else if pos > 1 then 183 | begin 184 | dec(pos); 185 | end; 186 | end; 187 | if mouseState=1 then MouseHide; 188 | clearEditBox; 189 | if length(msg)<>0 then 190 | begin 191 | tempstring:=copy(msg,offset+1,visiblecolumns); 192 | Setcolor(forColor); 193 | OuttextXY(x,y,tempstring); 194 | showcursor; 195 | end; 196 | if mouseState=1 then MouseShow; 197 | end; 198 | end; 199 | 200 | Procedure BackKeyAction; 201 | begin 202 | if length(msg)>1 then 203 | begin 204 | delete(msg,pos+offset-1,1); 205 | if pos > 1 then 206 | begin 207 | dec(pos); 208 | end 209 | else if offset>0 then 210 | begin 211 | dec(offset); 212 | end; 213 | tempstring:=copy(msg,offset+1,visiblecolumns); 214 | if mouseState=1 then MouseHide; 215 | clearEditBox; 216 | Setcolor(forColor); 217 | OuttextXY(x,y,tempstring); 218 | showcursor; 219 | if mouseState=1 then MouseShow; 220 | end; 221 | end; 222 | 223 | Procedure CharKeyAction; 224 | begin 225 | if length(msg)<>0 then 226 | begin 227 | if ((pos+offset)<>length(msg)) AND (cursorState=0) then 228 | begin 229 | msg[pos+offset]:=chr(mykey); 230 | end 231 | else 232 | begin 233 | insert(chr(mykey),msg,pos+offset); 234 | end; 235 | end 236 | else 237 | begin 238 | insert(chr(mykey)+#32,msg,pos+offset); 239 | end; 240 | if (pos ppos) then 302 | begin 303 | if (ppos > visiblecolumns) or (ppos<0) then exit; 304 | if ppos>length(msg) then ppos:=length(msg); 305 | MouseHide; 306 | hidecursor; 307 | pos:=ppos; 308 | showcursor; 309 | MouseShow; 310 | end; 311 | Repeat Until LKey=False; 312 | end; 313 | 314 | Function IsInEditBox : Boolean; 315 | Var 316 | my,mx,st : Integer; 317 | begin 318 | IsInEditBox:=False; 319 | MouseGetStatus(st,my,mx); 320 | if (mx>x-2) and (my>y-2) and (mx 0; 15 | End; 16 | 17 | Procedure SetBit(Position, Value : Byte; Var Changebyte : Byte); 18 | Var 19 | Bt : Byte; 20 | Begin 21 | Bt :=$01; 22 | Bt :=Bt Shl Position; 23 | If Value = 1 then 24 | Changebyte :=Changebyte Or Bt 25 | Else 26 | Begin 27 | Bt :=Bt Xor $FF; 28 | Changebyte :=Changebyte And Bt; 29 | End; 30 | End; 31 | 32 | begin 33 | end. -------------------------------------------------------------------------------- /RMCLIP/KEYS.PAS: -------------------------------------------------------------------------------- 1 | Unit Keys; 2 | 3 | Interface 4 | Uses Crt; 5 | 6 | const 7 | EscKey = 27; 8 | TabKey = 9; 9 | Leftkey = 19200; 10 | Rightkey = 19712; 11 | UpKey = 18432; 12 | DownKey = 20480; 13 | DeleteKey = 21248; 14 | InsKey = 20992; 15 | BackSpace = 8; 16 | HomeKey = 18176; 17 | Endkey = 20224; 18 | EnterKey = 13; 19 | PgUpKey = 18688; 20 | PgDownKey = 20736; 21 | F1Key = 15104; 22 | F2Key = 15360; 23 | F3Key = 15616; 24 | F4Key = 15872; 25 | 26 | Function GetKey : Word; 27 | 28 | Implementation 29 | 30 | Function GetKey : Word; 31 | var 32 | key :char; 33 | key2 :word; 34 | begin 35 | Repeat until keypressed = true; 36 | key:=readkey; 37 | case key of #0:begin 38 | key := readkey; 39 | Key2 := ord(key); 40 | getkey := (key2 shl 8); 41 | exit; 42 | end; 43 | else 44 | getkey:=ord(key); 45 | exit; 46 | end; 47 | end; 48 | 49 | end. -------------------------------------------------------------------------------- /RMCLIP/PARSE.PAS: -------------------------------------------------------------------------------- 1 | Program Parse; 2 | uses graph; 3 | Const 4 | list : array[1..5] of string = ('sm 320x200x16', 5 | 'rpcx 1 1 319 199 ', 6 | ' rpcx 1 1 319 199 NoPal', 7 | ' wpcx 1 1 200 100', 8 | 'wxgf 1 1 20 20 qb'); 9 | 10 | 11 | Procedure StripE(VAR ISTR : STRING); 12 | begin 13 | While (Length(ISTR) > 1) AND (ISTR[Length(ISTR)]=#32) do 14 | begin 15 | Delete(ISTR,Length(ISTR),1); 16 | end; 17 | end; 18 | 19 | Procedure StripS(VAR ISTR : STRING); 20 | begin 21 | While (Length(ISTR) > 1) AND (ISTR[1]=#32) do 22 | begin 23 | Delete(ISTR,1,1); 24 | end; 25 | end; 26 | 27 | Procedure StrToUp(Var ISTR : String); 28 | Var 29 | i : Word; 30 | begin 31 | For i:=1 to length(ISTR) do 32 | begin 33 | ISTR[i]:=UpCase(ISTR[i]); 34 | end; 35 | end; 36 | 37 | Procedure GetNextWord(Var IStr, OStr : String); 38 | var 39 | T : Word; 40 | 41 | begin 42 | StripS(ISTR); 43 | T:=POS(#32,ISTR); 44 | if T > 0 then 45 | begin 46 | OStr:=Copy(ISTR,1,T-1); 47 | StrToUp(OSTR); 48 | Delete(ISTR,1,T); 49 | end 50 | else if ISTR<>'' then 51 | begin 52 | OStr:=ISTR; 53 | ISTR:=''; 54 | end 55 | else 56 | begin 57 | OStr:=''; 58 | end; 59 | StrToUp(OSTR); 60 | end; 61 | 62 | Procedure ProcessLine(ListText: String); 63 | Var 64 | x,y,x2,y2 : Word; 65 | Error : Word; 66 | PAL : Boolean; 67 | CText : String; 68 | C : integer; 69 | 70 | Function GetCords : Boolean; 71 | begin 72 | GetCords:=FALSE; 73 | GetNextWord(listText,CText); 74 | VAL(CText,x,c); 75 | if c<>0 then exit; 76 | GetNextWord(listText,CText); 77 | VAL(CText,y,c); 78 | if c<>0 then exit; 79 | GetNextWord(listText,CText); 80 | VAL(CText,x2,c); 81 | if c<>0 then exit; 82 | GetNextWord(listText,CText); 83 | VAL(CText,y2,c); 84 | if c<>0 then exit; 85 | GetNextWord(listText,CText); 86 | PAL:=TRUE; 87 | If CText='NOPAL' then 88 | begin 89 | PAL:=FALSE; 90 | end; 91 | GetCords:=TRUE; 92 | end; 93 | 94 | begin 95 | GetNextWord(listText,CText); 96 | If CText = 'SM' then 97 | begin 98 | GetNextWord(listText,CText); 99 | If Ctext='320X200X16' then 100 | begin 101 | end 102 | else if Ctext='640X200X16' then 103 | begin 104 | end 105 | else if Ctext='640X200X16' then 106 | begin 107 | end 108 | else if Ctext='640X350X16' then 109 | begin 110 | end 111 | else if Ctext='640X480X16' then 112 | begin 113 | end; 114 | end 115 | else if CText = 'RPCX' then 116 | begin 117 | if GetCords then 118 | begin 119 | 120 | end; 121 | end; 122 | end; 123 | 124 | Procedure RLIST(ListFile : String); 125 | Var 126 | F : Text; 127 | ListText : String; 128 | begin 129 | Assign(F,ListFile); 130 | Reset(F); 131 | While Not Eof(F) do 132 | begin 133 | ReadLn(F,ListText); 134 | ProcessLine(ListText); 135 | end; 136 | Close(F); 137 | end; 138 | 139 | begin 140 | end. -------------------------------------------------------------------------------- /RMCLIP/RKEY.PAS: -------------------------------------------------------------------------------- 1 | 2 | Unit rKey; 3 | Interface 4 | Type 5 | keyRec = Record 6 | UserName : String[25]; 7 | Address : String[25]; 8 | City : String[25]; 9 | State : String[25]; 10 | Country : String[25]; 11 | Zip : String[25]; 12 | Phone : String[25]; 13 | UserNum : String[4]; 14 | C1 : LongInt; 15 | C2 : LongInt; 16 | C3 : LongInt; 17 | C4 : LongInt; 18 | C5 : LongInt; 19 | C6 : LongInt; 20 | C7 : LongInt; 21 | C8 : LongInt; 22 | FC : LongInt; 23 | Extra : String[10]; 24 | End; 25 | 26 | Procedure CreateKey(Var zKey : KeyRec); 27 | Procedure ReadKey(Var zKey : KeyRec;KeyFileName : String); 28 | Procedure WriteKey(Var zKey : KeyRec;KeyFileName : String); 29 | Function ValidKey(zKey : KeyRec) : Boolean; 30 | 31 | Implementation 32 | uses dos; 33 | 34 | Procedure CreateKey(Var zKey : KeyRec); 35 | Var 36 | i : Word; 37 | begin 38 | Write('Enter User Name: '); 39 | ReadLn(zKey.UserName); 40 | Write('Enter Adress: '); 41 | ReadLn(zKey.Address); 42 | Write('Enter City: '); 43 | ReadLn(zKey.City); 44 | Write('Enter State: '); 45 | ReadLn(zKey.State); 46 | Write('Enter Country: '); 47 | ReadLn(zKey.Country); 48 | Write('Enter Zip: '); 49 | ReadLn(zKey.Zip); 50 | Write('Enter Phone: '); 51 | ReadLn(zKey.Phone); 52 | 53 | Write('User Number: '); 54 | ReadLn(zKey.UserNum); 55 | 56 | zKey.C1:=2465; 57 | 58 | For i:=0 to 25 do 59 | begin 60 | {$IFDEF MEGACLIP} 61 | zKey.C1:=zKey.C1+((((ORD(zKey.UserName[i])*3257)+69387)*378)+3302); 62 | {$ELSE} 63 | zKey.C1:=zKey.C1+((((ORD(zKey.UserName[i])*43257)+69387)*3478)+34302); 64 | {$ENDIF} 65 | end; 66 | WriteLn(zKey.C1); 67 | 68 | zKey.C2:=12236; 69 | For i:=0 to 25 do 70 | begin 71 | zKey.C2:=zKey.C2+((((ORD(zKey.Address[i])*83952)+99307)*3546)+41322); 72 | end; 73 | WriteLn(zKey.C2); 74 | 75 | zKey.C3:=24465; 76 | For i:=0 to 25 do 77 | begin 78 | zKey.C3:=zKey.C3+((((ORD(zKey.City[i])*83257)+28387)*1428)+14301); 79 | end; 80 | WriteLn(zKey.C3); 81 | 82 | zKey.C4:=2465; 83 | For i:=0 to 25 do 84 | begin 85 | zKey.C4:=zKey.C4+((((ORD(zKey.State[i])*23437)+99457)*433)+74312); 86 | end; 87 | WriteLn(zKey.C4); 88 | 89 | zKey.C5:=32465; 90 | For i:=0 to 25 do 91 | begin 92 | zKey.C5:=zKey.C5+((((ORD(zKey.Zip[i])*83467)+48367)*21488)+4312); 93 | end; 94 | WriteLn(zKey.C5); 95 | 96 | zKey.C6:=23465; 97 | For i:=0 to 25 do 98 | begin 99 | zKey.C6:=zKey.C6+((((ORD(zKey.Phone[i])*267)+92979)*4183)+33121); 100 | end; 101 | WriteLn(zKey.C6); 102 | 103 | zKey.C7:=23; 104 | For i:=0 to 4 do 105 | begin 106 | zKey.C7:=zKey.C7+((((ORD(zKey.UserNum[i])*7)+379)*43)+321); 107 | end; 108 | WriteLn(zKey.C7); 109 | 110 | zKey.C8:=2265; 111 | For i:=0 to 25 do 112 | begin 113 | zKey.C8:=zKey.C8+((((ORD(zKey.Country[i])*23447)+99497)*433)+74312); 114 | end; 115 | WriteLn(zKey.C8); 116 | 117 | end; 118 | 119 | Procedure WriteKey(Var zKey : KeyRec;KeyFileName : String); 120 | Var 121 | F : File; 122 | tempBuf : Array[1..256] of Byte; 123 | i : WOrd; 124 | Error : Word; 125 | begin 126 | Move(zKey,tempBuf,SizeOf(KeyRec)); 127 | For i:=1 to 256 do 128 | begin 129 | tempBuf[i]:=256-tempBuf[i]; 130 | end; 131 | {$I-} 132 | Assign(F,KeyFileName); 133 | Rewrite(F,1); 134 | BlockWrite(F,tempBuf,256); 135 | Close(F); 136 | Error:=IORESULT; 137 | {$I+} 138 | End; 139 | 140 | Procedure ReadKey(Var zKey : KeyRec;KeyFileName : String); 141 | Var 142 | F : File; 143 | tempBuf : Array[1..256] of Byte; 144 | i : Word; 145 | Error : Word; 146 | begin 147 | {$I-} 148 | Assign(F,KeyFileName); 149 | Reset(F,1); 150 | BlockRead(F,tempbuf,256); 151 | Close(F); 152 | Error:=IORESULT; 153 | {$I+} 154 | For i:=1 to 256 do 155 | begin 156 | tempBuf[i]:=256-tempBuf[i]; 157 | end; 158 | Move(tempBuf,zKey,SizeOf(KeyRec)); 159 | End; 160 | 161 | Function ValidKey(zKey : KeyRec) : Boolean; 162 | Var 163 | C1,C2,C3, 164 | C4,C5,C6, 165 | C7,C8 : LongInt; 166 | i : Word; 167 | begin 168 | ValidKey:=False; 169 | 170 | C1:=2465; 171 | For i:=0 to 25 do 172 | begin 173 | 174 | {$IFDEF MEGACLIP} 175 | C1:=C1+((((ORD(zKey.UserName[i])*3257)+69387)*378)+3302); 176 | {$ELSE} 177 | C1:=C1+((((ORD(zKey.UserName[i])*43257)+69387)*3478)+34302); 178 | {$ENDIF} 179 | 180 | end; 181 | 182 | C2:=12236; 183 | For i:=0 to 25 do 184 | begin 185 | C2:=C2+((((ORD(zKey.Address[i])*83952)+99307)*3546)+41322); 186 | end; 187 | 188 | C3:=24465; 189 | For i:=0 to 25 do 190 | begin 191 | C3:=C3+((((ORD(zKey.City[i])*83257)+28387)*1428)+14301); 192 | end; 193 | 194 | C4:=2465; 195 | For i:=0 to 25 do 196 | begin 197 | C4:=C4+((((ORD(zKey.State[i])*23437)+99457)*433)+74312); 198 | end; 199 | 200 | C5:=32465; 201 | For i:=0 to 25 do 202 | begin 203 | C5:=C5+((((ORD(zKey.Zip[i])*83467)+48367)*21488)+4312); 204 | end; 205 | 206 | C6:=23465; 207 | For i:=0 to 25 do 208 | begin 209 | C6:=C6+((((ORD(zKey.Phone[i])*267)+92979)*4183)+33121); 210 | end; 211 | 212 | C7:=23; 213 | For i:=0 to 4 do 214 | begin 215 | C7:=C7+((((ORD(zKey.UserNum[i])*7)+379)*43)+321); 216 | end; 217 | 218 | C8:=2265; 219 | For i:=0 to 25 do 220 | begin 221 | C8:=C8+((((ORD(zKey.Country[i])*23447)+99497)*433)+74312); 222 | end; 223 | 224 | If (zKey.C1 = C1) AND (zKey.C2 = C2) AND (zKey.C3 = C3) AND (zKey.C4 = C4) 225 | AND (zKey.C5 = C5) AND (zKey.C6 = C6) AND (zKey.C7 = C7) AND (zKey.C8 = C8) then 226 | begin 227 | ValidKey:=True; 228 | exit; 229 | end; 230 | ValidKey:=False; 231 | End; 232 | 233 | begin 234 | end. 235 | -------------------------------------------------------------------------------- /RMCLIP/RLIST.PAS: -------------------------------------------------------------------------------- 1 | Unit RList; 2 | 3 | Interface 4 | uses dos,vars,rkey,graph,screen,wxgf,rwpcx,rwbmp,wprf,rwraw,rwpal; 5 | 6 | Procedure ReadLIST(ListFile : String); 7 | 8 | Implementation 9 | 10 | 11 | Procedure StripE(VAR ISTR : STRING); 12 | begin 13 | While (Length(ISTR) > 1) AND (ISTR[Length(ISTR)]=#32) do 14 | begin 15 | Delete(ISTR,Length(ISTR),1); 16 | end; 17 | end; 18 | 19 | Procedure StripS(VAR ISTR : STRING); 20 | begin 21 | While (Length(ISTR) > 1) AND (ISTR[1]=#32) do 22 | begin 23 | Delete(ISTR,1,1); 24 | end; 25 | end; 26 | 27 | Procedure StrToUp(Var ISTR : String); 28 | Var 29 | i : Word; 30 | begin 31 | For i:=1 to length(ISTR) do 32 | begin 33 | ISTR[i]:=UpCase(ISTR[i]); 34 | end; 35 | end; 36 | 37 | Procedure GetNextWord(Var IStr, OStr : String); 38 | var 39 | T : Word; 40 | 41 | begin 42 | StripS(ISTR); 43 | T:=POS(#32,ISTR); 44 | if T > 0 then 45 | begin 46 | OStr:=Copy(ISTR,1,T-1); 47 | StrToUp(OSTR); 48 | Delete(ISTR,1,T); 49 | end 50 | else if ISTR<>'' then 51 | begin 52 | OStr:=ISTR; 53 | ISTR:=''; 54 | end 55 | else 56 | begin 57 | OStr:=''; 58 | end; 59 | StrToUp(OSTR); 60 | end; 61 | 62 | Procedure ExitWithReminder; 63 | begin 64 | closegraph; 65 | Writeln('Saving in the 256 color modes requires registration!'); 66 | Writeln('Try saving in 16 color modes.'); 67 | writeln; 68 | halt; 69 | end; 70 | 71 | Procedure Run(ListText : String); 72 | Var 73 | Filename : String; 74 | Error : Word; 75 | begin 76 | GetNextWord(ListText,Filename); 77 | SwapVectors; 78 | Exec(filename,ListText); 79 | SwapVectors; 80 | Error:=DosError; 81 | if (Error<>0) then 82 | begin 83 | Closegraph; 84 | Writeln(Error); 85 | halt; 86 | end; 87 | end; 88 | 89 | 90 | 91 | Procedure ProcessLine(ListText: String); 92 | Var 93 | x,y,x2,y2 : Word; 94 | Filename : String; 95 | Error : Word; 96 | PAL,MFail : Boolean; 97 | CText : String; 98 | C : integer; 99 | 100 | Function GetCords : Boolean; 101 | begin 102 | GetCords:=FALSE; 103 | GetNextWord(listText,CText); 104 | VAL(CText,x,c); 105 | if c<>0 then exit; 106 | GetNextWord(listText,CText); 107 | VAL(CText,y,c); 108 | if c<>0 then exit; 109 | GetNextWord(listText,CText); 110 | VAL(CText,x2,c); 111 | if c<>0 then exit; 112 | GetNextWord(listText,CText); 113 | VAL(CText,y2,c); 114 | if c<>0 then exit; 115 | GetNextWord(listText,CText); 116 | PAL:=TRUE; 117 | If CText='NOPAL' then 118 | begin 119 | PAL:=FALSE; 120 | end; 121 | GetCords:=TRUE; 122 | end; 123 | 124 | begin 125 | GetNextWord(listText,CText); 126 | if Ctext = #39 then 127 | begin 128 | 129 | end 130 | else If CText = 'SM' then 131 | begin 132 | CloseGraph; 133 | GetNextWord(listText,CText); 134 | If Ctext='320X200X16' then 135 | begin 136 | MFail:=SetSVGA16(0); 137 | end 138 | else if Ctext='640X200X16' then 139 | begin 140 | MFail:=SetSVGA16(1); 141 | end 142 | else if Ctext='640X200X16' then 143 | begin 144 | MFail:=SetSVGA16(2); 145 | end 146 | else if Ctext='640X350X16' then 147 | begin 148 | MFail:=SetSVGA16(3); 149 | end 150 | else if Ctext='640X480X16' then 151 | begin 152 | MFail:=SetSVGA16(4); 153 | end 154 | else if Ctext='800X600X16' then 155 | begin 156 | MFail:=SetSVGA16(5); 157 | end 158 | else if Ctext='1024X768X16' then 159 | begin 160 | MFail:=SetSVGA16(6); 161 | end 162 | else if Ctext='320X200X256' then 163 | begin 164 | MFail:=SetVGA256(0); 165 | end 166 | else if Ctext='640X400X256' then 167 | begin 168 | MFail:=SetVGA256(1); 169 | end 170 | else if Ctext='640X480X256' then 171 | begin 172 | MFail:=SetVGA256(2); 173 | end 174 | else if Ctext='800X600X256' then 175 | begin 176 | MFail:=SetVGA256(3); 177 | end 178 | else if Ctext='1024X768X256' then 179 | begin 180 | MFail:=SetVGA256(4); 181 | end 182 | else 183 | begin 184 | writeln('invalid mode ',Ctext); 185 | end; 186 | end 187 | else if CText = 'RUN' then 188 | begin 189 | Run(ListText); 190 | end 191 | else if CText = 'RPCX' then 192 | begin 193 | GetNextWord(ListText,filename); 194 | if GetCords then 195 | begin 196 | if DisPcxImg(x,y,x2,y2,PAL,filename) <> 0 then 197 | begin 198 | end; 199 | end; 200 | end 201 | else if CText = 'WPCX' then 202 | begin 203 | GetNextWord(ListText,filename); 204 | if GetCords then 205 | begin 206 | if SavePcxImg(x,y,x2,y2,filename) <> 0 then 207 | begin 208 | end; 209 | end; 210 | end 211 | else if CText = 'RBMP' then 212 | begin 213 | GetNextWord(ListText,filename); 214 | if GetCords then 215 | begin 216 | if ReadBMP(x,y,x2,y2,PAL,Filename) <> 0 then 217 | begin 218 | end; 219 | end; 220 | end 221 | else if CText = 'WBMP' then 222 | begin 223 | GetNextWord(ListText,filename); 224 | if GetCords then 225 | begin 226 | if WriteBMP(x,y,x2,y2,Filename) <> 0 then 227 | begin 228 | end; 229 | end; 230 | end 231 | else if CText = 'RRAW' then 232 | begin 233 | GetNextWord(ListText,filename); 234 | if GetCords then 235 | begin 236 | if ReadRaw(x,y,x2,y2,PAL,Filename) <> 0 then 237 | begin 238 | end; 239 | end; 240 | end 241 | else if CText = 'WRAW' then 242 | begin 243 | GetNextWord(ListText,filename); 244 | if GetCords then 245 | begin 246 | if WriteRAW(x,y,x2,y2,Filename) <> 0 then 247 | begin 248 | end; 249 | end; 250 | end 251 | else if CText = 'RPAL' then 252 | begin 253 | GetNextWord(ListText,filename); 254 | if ReadPAL(Filename) <> 0 then 255 | begin 256 | end; 257 | end 258 | else if CText = 'WPAL' then 259 | begin 260 | GetNextWord(ListText,filename); 261 | if WritePAL(Filename) <> 0 then 262 | begin 263 | end; 264 | end 265 | else if CText = 'WSPR' then 266 | begin 267 | GetNextWord(ListText,filename); 268 | if GetCords then 269 | begin 270 | if WriteSPR(x,y,x2,y2,Filename) <> 0 then 271 | begin 272 | end; 273 | end; 274 | end 275 | else if CText = 'WPPR' then 276 | begin 277 | GetNextWord(ListText,filename); 278 | if GetCords then 279 | begin 280 | if WritePPR(x,y,x2,y2,Filename) <> 0 then 281 | begin 282 | end; 283 | end; 284 | end 285 | else if (CText = 'WXGF') then 286 | begin 287 | GetNextWord(ListText,CText); 288 | if (CText = 'TP') or (Ctext='TC') then 289 | begin 290 | GetNextWord(ListText,filename); 291 | if GetCords then 292 | begin 293 | if WriteXGF(x,y,x2,y2,1,Filename) <> 0 then 294 | begin 295 | end; 296 | end; 297 | end 298 | else if (CText = 'QC') or (Ctext='QB') then 299 | begin 300 | GetNextWord(ListText,filename); 301 | if GetCords then 302 | begin 303 | if WriteSPR(x,y,x2,y2,Filename) <> 0 then 304 | begin 305 | end; 306 | end; 307 | end; 308 | end; 309 | 310 | end; 311 | 312 | Procedure ReadLIST(ListFile : String); 313 | Var 314 | F : Text; 315 | ListText : String; 316 | Error : Word; 317 | begin 318 | if POS('@',ListFile) = 1 then 319 | begin 320 | Delete(ListFile,1,1); 321 | end; 322 | {$I-} 323 | Assign(F,ListFile); 324 | Reset(F); 325 | Error:=IORESULT; 326 | if Error <> 0 then 327 | begin 328 | WriteLn('Error: ',Error); 329 | halt; 330 | end; 331 | if SetSVGA16(0) then 332 | begin 333 | end; 334 | 335 | While (Not Eof(F)) AND (Error=0) do 336 | begin 337 | ReadLn(F,ListText); 338 | Error:=IORESULT; 339 | ProcessLine(ListText); 340 | end; 341 | Close(F); 342 | {$I-} 343 | Closegraph; 344 | end; 345 | 346 | begin 347 | end. 348 | -------------------------------------------------------------------------------- /RMCLIP/RWBMP.PAS: -------------------------------------------------------------------------------- 1 | Unit rwbmp; 2 | Interface 3 | Function ReadBMP(x,y,x2,y2 : Word;lp : Boolean;Filename : String) : Word; 4 | Function WriteBMP(x,y,x2,y2 : Word;Filename : String) : Word; 5 | Implementation 6 | uses dos,graph,bgiPal; 7 | 8 | type 9 | bmpRec = Record 10 | ID : Array[1..2] of CHAR; 11 | Fsize : LongInt; 12 | reserved1 : Word; 13 | reserved2 : Word; 14 | offbits : LongInt; 15 | 16 | biSize : LongInt; 17 | biWidth : LongInt; 18 | biHeight : Longint; 19 | biPlanes : Word; 20 | bits : Word; 21 | biCompression : LongInt; 22 | biSizeImage : LongInt; 23 | biXpelsPerMeter : LongInt; 24 | biyPelsPerMeter : LongInt; 25 | biClrUsed : LongInt; 26 | biClrImportant : LongInt; 27 | End; 28 | 29 | 30 | bmpRGB = Record 31 | blue : byte; 32 | green : byte; 33 | red : byte; 34 | filler : byte; 35 | End; 36 | 37 | LineBufType = Array[0..2047] of Byte; 38 | 39 | 40 | Procedure DisLine(x,y : Word;Var Splane : LineBufType;width : Word); 41 | Var 42 | i : Word; 43 | cl : array[0..255] of Word; 44 | mc,oc : Word; 45 | begin 46 | Fillchar(cl,sizeof(cl),0); 47 | For i:=0 to width-1 do 48 | begin 49 | Inc(cL[Splane[i]]); 50 | end; 51 | mc:=0; 52 | oc:=0; 53 | for i:=0 to 255 do 54 | begin 55 | if cL[i]>mc then 56 | begin 57 | mc:=cL[i]; 58 | oc:=i; 59 | end; 60 | end; 61 | SetColor(oc); 62 | Line(x,y,x+width-1,y); 63 | 64 | For i:=0 to width-1 do 65 | begin 66 | if Splane[i]<>oc then 67 | begin 68 | PutPixel(x+i,y,Splane[i]); 69 | end; 70 | end; 71 | end; 72 | 73 | 74 | 75 | Procedure PackedToSingle(Var imgLine,uline : lineBufType;bpl,width : Word); 76 | Var 77 | i : Word; 78 | xp : Word; 79 | begin 80 | xp:=0; 81 | for i:=0 to BPL-1 do 82 | begin 83 | uline[xp+1]:=imgLine[i] SHL 4; 84 | uline[xp+1]:=uline[xp+1] SHR 4; 85 | uline[xp]:=imgLine[i] SHR 4; 86 | inc(xp,2); 87 | if xp>=Width then exit; 88 | end; 89 | end; 90 | 91 | Procedure SingleToPacked(Var uline,imgline : lineBufType;bpl : Word); 92 | Var 93 | i : Word; 94 | xp : Word; 95 | begin 96 | xp:=0; 97 | for i:=0 to bpl-1 do 98 | begin 99 | imgline[i]:=(uLine[xp] SHL 4)+uline[xp+1]; 100 | inc(xp,2); 101 | end; 102 | end; 103 | 104 | Function ReadBMP(x,y,x2,y2 : Word;lp : Boolean;Filename : String) : Word; 105 | Var 106 | mybmp : bmpRec; 107 | myWidth : Word; 108 | myHeight : Word; 109 | myColNum : Word; 110 | FSize : LongInt; 111 | BPL : Word; 112 | F : File; 113 | uline, 114 | imgline : lineBufType; 115 | bmpPal : Array[0..255] of bmpRGB; 116 | stdPal : PaletteT; 117 | i,j : Word; 118 | Error : Word; 119 | begin 120 | myHeight:=y2-y+1; 121 | myWidth:=x2-x+1; 122 | {$I-} 123 | assign(F,filename); 124 | reset(F,1); 125 | Fsize:=FileSize(F); 126 | 127 | Blockread(F,mybmp,sizeof(mybmp)); 128 | 129 | Error:=IORESULT; 130 | if Error <> 0 then 131 | begin 132 | ReadBMP:=Error; 133 | exit; 134 | end; 135 | 136 | if NOT ((mybmp.biCompression=0) AND (mybmp.ID='BM') AND ((mybmp.bits=4) OR (mybmp.bits=8))) then 137 | begin 138 | ReadBMP:=1000; 139 | Close(F); 140 | Error:=IORESULT; 141 | exit; 142 | end; 143 | 144 | if myHeight>mybmp.biHeight then 145 | begin 146 | myHeight:=myBmp.biHeight; 147 | end; 148 | 149 | if myWidth>mybmp.biWidth then 150 | begin 151 | myWidth:=myBmp.biWidth; 152 | end; 153 | 154 | myColNum:=1 SHL myBmp.bits; 155 | if myBmp.Bits=4 then 156 | begin 157 | blockread(f,bmpPal,64); 158 | BPL:=((myBmp.biWidth+7) div 8); 159 | BPL:=(BPL*8) DIV 2; 160 | Seek(F,Fsize-LONGINT(bpl)*LONGINT(myHeight)); 161 | for j:=myHeight downto 1 do 162 | begin 163 | Blockread(f,imgLine,BPL); 164 | Error:=IORESULT; 165 | if Error <> 0 then 166 | begin 167 | Close(F); 168 | ReadBMP:=Error; 169 | exit; 170 | end; 171 | PackedToSingle(imgLine,Uline,BPL,myWidth); 172 | DisLine(x,y+j-1,Uline,myWidth); 173 | end; 174 | end 175 | else if myBmp.bits=8 then 176 | begin 177 | blockread(f,bmpPal,1024); 178 | Error:=IORESULT; 179 | if Error <> 0 then 180 | begin 181 | Close(F); 182 | ReadBMP:=Error; 183 | exit; 184 | end; 185 | BPL:=(mybmp.biWidth+3) div 4; 186 | BPL:=BPL*4; 187 | Seek(F,Fsize-LONGINT(bpl)*LONGINT(myHeight)); 188 | for j:=myHeight downto 1 do 189 | begin 190 | Blockread(f,ULine,BPL); 191 | DisLine(x,y+j-1,Uline,myWidth); 192 | end; 193 | end 194 | else 195 | begin 196 | ReadBMP:=1000; 197 | Close(F); 198 | Error:=IORESULT; 199 | exit; 200 | end; 201 | 202 | Close(f); 203 | if GetMaxColor < (myColNum-1) then 204 | begin 205 | myColNum:=GetMaxColor+1; 206 | end; 207 | 208 | if lp=TRUE then 209 | begin 210 | For i:=0 to myColNum-1 do 211 | begin 212 | StdPal[i,0]:=bmpPal[i].red SHR 2; 213 | StdPal[i,1]:=bmpPal[i].green SHR 2; 214 | StdPal[i,2]:=bmpPal[i].blue SHR 2; 215 | end; 216 | SetPaletteList(StdPal,myColNum); 217 | end; 218 | 219 | Error:=IORESULT; 220 | ReadBMP:=Error; 221 | {$I+} 222 | end; 223 | 224 | 225 | Function WriteBMP(x,y,x2,y2 : Word;Filename : String) : Word; 226 | Var 227 | mybmp : bmpRec; 228 | myWidth : Word; 229 | myHeight : Word; 230 | myNumCol : Word; 231 | BPL : Word; 232 | F : File; 233 | uline, 234 | imgline : lineBufType; 235 | bmpPal : Array[0..255] of bmpRGB; 236 | stdPal : PaletteT; 237 | i,j : Word; 238 | Error : Word; 239 | begin 240 | myHeight:=y2-y+1; 241 | myWidth:=x2-x+1; 242 | myNumCol:=GetMAxColor+1; 243 | If MyNumCol=16 then 244 | begin 245 | BPL:=(myWidth+7) Div 8; 246 | BPL:=(BPL*8) DIV 2; 247 | end 248 | else 249 | begin 250 | BPL:=(myWidth+3) div 4; 251 | BPL:=BPL*4; 252 | end; 253 | FillChar(myBmp,SizeOf(myBMP),0); 254 | mybmp.ID:='BM'; 255 | mybmp.offbits :=SizeOf(myBMP)+(mynumCol*4); 256 | mybmp.Fsize :=mybmp.offbits+(BPL*myHeight); 257 | mybmp.biSize :=40; 258 | mybmp.biWidth :=myWidth; 259 | mybmp.biHeight:=myHeight; 260 | mybmp.biPlanes:=1; 261 | mybmp.bisizeImage:=mybmp.fsize-mybmp.offbits; 262 | if myNumCol=16 then 263 | begin 264 | mybmp.bits:=4; 265 | end 266 | else 267 | begin 268 | mybmp.bits:=8; 269 | end; 270 | 271 | GrabPaletteList(StdPal,myNumCol); 272 | For i:=0 to myNumCol-1 do 273 | begin 274 | bmpPal[i].red:=StdPal[i,0] SHL 2; 275 | bmpPal[i].green:=StdPal[i,1] SHL 2; 276 | bmpPal[i].blue:=StdPal[i,2] SHL 2; 277 | bmpPal[i].filler:=0; 278 | end; 279 | 280 | {$I-} 281 | assign(F,filename); 282 | rewrite(F,1); 283 | 284 | BlockWrite(F,mybmp,sizeof(mybmp)); 285 | error:=IORESULT; 286 | if Error<>0 then 287 | begin 288 | WriteBMP:=Error; 289 | Close(F); 290 | Error:=IORESULT; 291 | exit; 292 | end; 293 | 294 | 295 | BlockWrite(F,bmpPal,myNumCol*4); 296 | 297 | if myNumCol=16 then 298 | begin 299 | For j:=y2 downto y do 300 | begin 301 | For i:=1 to myWidth do 302 | begin 303 | (* uline[i-1]:=IconImage[x+i-1,j];*) 304 | uline[i-1]:=GetPixel(x+i-1,j); 305 | end; 306 | SingleToPacked(uline,imgline,BPL); 307 | BlockWrite(F,imgLine,BPL); 308 | error:=IORESULT; 309 | if Error<>0 then 310 | begin 311 | WriteBMP:=Error; 312 | Close(F); 313 | Error:=IORESULT; 314 | exit; 315 | end; 316 | end; 317 | end 318 | else 319 | begin 320 | For j:=y2 downto y do 321 | begin 322 | For i:=1 to myWidth do 323 | begin 324 | (* uline[i-1]:=IconImage[x+i-1,j];*) 325 | uline[i-1]:=GetPixel(x+i-1,j); 326 | end; 327 | BlockWrite(F,uLine,BPL); 328 | error:=IORESULT; 329 | if Error<>0 then 330 | begin 331 | WriteBMP:=Error; 332 | Close(F); 333 | Error:=IORESULT; 334 | exit; 335 | end; 336 | end; 337 | end; 338 | Close(F); 339 | Error:=IORESULT; 340 | WriteBMP:=Error; 341 | {$I+} 342 | end; 343 | 344 | begin 345 | end. -------------------------------------------------------------------------------- /RMCLIP/RWPAL.PAS: -------------------------------------------------------------------------------- 1 | Unit RWPal; 2 | Interface 3 | uses dos,graph,bgiPal; 4 | Function ReadPAL(Filename : String) : Word; 5 | Function WritePAL(Filename : String) : Word; 6 | Implementation 7 | 8 | 9 | Function WritePAL(FileName : String): Word; 10 | Var 11 | F : File; 12 | myPal : PaletteT; 13 | Colors : Word; 14 | Error : Word; 15 | begin 16 | {$I-} 17 | Colors:=GetMaxColor+1; 18 | GrabPaletteList(myPal,Colors); 19 | Assign(F,FileName); 20 | Rewrite(F,1); 21 | BlockWrite(F,myPAL,Colors*3); 22 | Close(F); 23 | Error:=IORESULT; 24 | WritePAL:=Error; 25 | {$I+} 26 | end; 27 | 28 | Function ReadPAL(Filename : String) : Word; 29 | Var 30 | F : File; 31 | Fsize : LongInt; 32 | Colors : word; 33 | Error : Word; 34 | myPal : PaletteT; 35 | begin 36 | Colors:=GetMaxCOlor+1; 37 | {$I-} 38 | Assign(F,FileName); 39 | Reset(F,1); 40 | Fsize:=FIleSize(F); 41 | If (Fsize<>48) AND (Fsize<>768) then 42 | begin 43 | ReadPAL:=1000; 44 | Exit; 45 | end; 46 | BlockRead(F,myPAL,Fsize); 47 | Close(F); 48 | Error:=IORESULT; 49 | {$I+} 50 | ReadPAl:=Error; 51 | If Error = 0 then 52 | begin 53 | If Colors > (Fsize div 3) then 54 | begin 55 | Colors:=(Fsize div 3); 56 | end; 57 | SetPaletteList(myPal,Colors); 58 | end; 59 | end; 60 | 61 | begin 62 | end. 63 | -------------------------------------------------------------------------------- /RMCLIP/RWRAW.PAS: -------------------------------------------------------------------------------- 1 | Unit RWRaw; 2 | Interface 3 | uses dos,graph,Bits,bgiPal; 4 | 5 | Function ReadRaw(x,y,x2,y2 : Word; pal : Boolean;FileName : String) : Word; 6 | Function WriteRaw(x,y,x2,y2 : Word;FileName : String) : Word; 7 | 8 | Implementation 9 | 10 | type 11 | linebuftype = array[0..2047] of byte; 12 | 13 | Function WriteRaw(x,y,x2,y2 : Word;FileName : String) : Word; 14 | Var 15 | Error,i ,j : Word; 16 | F : File; 17 | Width,Height,Colors : Word; 18 | Tbuf : LinebufType; 19 | myPal : PaletteT; 20 | begin 21 | Width:=x2-x+1; 22 | Height:=y2-y+1; 23 | Colors:=GetMaxColor+1; 24 | 25 | GrabPaletteList(myPal,Colors); 26 | 27 | {$I-} 28 | Assign(F,FileName); 29 | Rewrite(F,1); 30 | BlockWrite(F,Width,2); 31 | BlockWrite(F,Height,2); 32 | BlockWrite(F,Colors,2); 33 | 34 | BlockWrite(F,myPal,Colors*3); 35 | 36 | For j:=y to y2 do 37 | begin 38 | For i:=1 to Width do 39 | begin 40 | Tbuf[i-1]:=GetPixel(x+i-1,j); 41 | end; 42 | BlockWrite(F,TBuf,Width); 43 | Error:=IORESULT; 44 | If Error<>0 then 45 | begin 46 | WriteRaw:=Error; 47 | Exit; 48 | end; 49 | end; 50 | 51 | Close(F); 52 | Error:=IORESULT; 53 | WriteRaw:=Error; 54 | {$I+} 55 | end; 56 | 57 | Function ReadRaw(x,y,x2,y2 : Word; pal : Boolean;FileName : String) : Word; 58 | Var 59 | Error,i ,j : Word; 60 | F : File; 61 | Width,Height,Colors : Word; 62 | myWidth,myHeight : Word; 63 | Fcol : Byte; 64 | Tbuf : LineBufType; 65 | myPal : PaletteT; 66 | size,fsize : LongInt; 67 | begin 68 | myWidth:=x2-x+1; 69 | myHeight:=y2-y+1; 70 | {$I-} 71 | Assign(F,FileName); 72 | Reset(F,1); 73 | Error:=IORESULT; 74 | if Error <>0 then 75 | begin 76 | ReadRaw:=Error; 77 | Exit; 78 | end; 79 | 80 | fsize:=FileSize(F); 81 | 82 | BlockRead(F,Width,2); 83 | BlockRead(F,Height,2); 84 | BlockRead(F,Colors,2); 85 | 86 | size:=LongInt(Width)*LongInt(Height)+LongInt(Colors*3)+6; 87 | if size<>fsize then 88 | begin 89 | Close(f); 90 | ReadRaw:=1000; 91 | Error:=IORESULT; 92 | Exit; 93 | end; 94 | If Colors > 0 Then 95 | begin 96 | BlockRead(F,myPal,Colors*3); 97 | end; 98 | If myHeight > Height then myHeight:=Height; 99 | if myWidth > Width then myWidth:=Width; 100 | For j:=1 to myHeight do 101 | begin 102 | BlockRead(F,TBuf,Width); 103 | Error:=IORESULT; 104 | If Error<>0 then 105 | begin 106 | ReadRaw:=Error; 107 | Exit; 108 | end; 109 | For i:=1 to myWidth do 110 | begin 111 | PutPixel(x+i-1,y+j-1,Tbuf[i-1]); 112 | end; 113 | end; 114 | Close(F); 115 | 116 | if Colors > (GetMaxColor+1) then Colors:=GetMaxColor+1; 117 | If Pal then 118 | begin 119 | If Colors > 0 Then SetPaletteList(myPal,Colors); 120 | end; 121 | Error:=IORESULT; 122 | ReadRaw:=Error; 123 | {$I+} 124 | end; 125 | 126 | 127 | begin 128 | end. -------------------------------------------------------------------------------- /RMCLIP/SCREEN.PAS: -------------------------------------------------------------------------------- 1 | Unit Screen; 2 | Interface 3 | Function SetSVGA16(Mode : Word) : Boolean; 4 | Function SetVGA256(Mode :Word) : Boolean; 5 | Implementation 6 | uses graph; 7 | 8 | 9 | procedure Svga16; external; 10 | {$L SVGA16.OBJ } 11 | 12 | Procedure Svga256 ;external; 13 | {$L svga256.obj} 14 | 15 | 16 | {$F+} 17 | Function DetectVGA256 : integer; 18 | begin 19 | DetectVGA256 :=0; 20 | end; 21 | {$F-} 22 | 23 | {$F+} 24 | Function DetectVGA16 : integer; 25 | begin 26 | DetectVGA16 :=0; 27 | end; 28 | {$F-} 29 | 30 | 31 | Function SetVGA256(Mode : Word) : Boolean; 32 | Var 33 | Error : Word; 34 | gd,gm : Integer; 35 | begin 36 | SetVga256:=TRUE; 37 | 38 | GD :=InstallUserDriver('svga256',@detectvga256); 39 | gM :=Mode; 40 | 41 | IF RegisterBGIDriver(@svga256) < 0 then 42 | begin 43 | SetVGA256:=FALSE; 44 | end 45 | else 46 | begin 47 | Initgraph(gd,gm,''); 48 | If GraphResult <> 0 then 49 | begin 50 | SetVGA256:=FALSE; 51 | end; 52 | end; 53 | 54 | end; 55 | 56 | Function SetSVGA16(Mode : Word) : Boolean; 57 | Var 58 | gd,gm : Integer; 59 | begin 60 | GD :=InstallUserDriver('svga16',@detectvga16); 61 | gm:=Mode; 62 | 63 | IF RegisterBGIDriver(@svga16) < 0 then 64 | begin 65 | SetSVGA16:=FALSE; 66 | end 67 | else 68 | begin 69 | Initgraph(gd,gm,''); 70 | If GraphResult <> 0 then 71 | begin 72 | SetSVGA16:=FALSE; 73 | end; 74 | end; 75 | end; 76 | 77 | 78 | begin 79 | end. 80 | -------------------------------------------------------------------------------- /RMCLIP/SVGA16.BGI: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RetroNick2020/raster-master-dos/51aa355531856ace663ac7eb4b65d02a39230bb7/RMCLIP/SVGA16.BGI -------------------------------------------------------------------------------- /RMCLIP/SVGA16.OBJ: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RetroNick2020/raster-master-dos/51aa355531856ace663ac7eb4b65d02a39230bb7/RMCLIP/SVGA16.OBJ -------------------------------------------------------------------------------- /RMCLIP/SVGA256.BGI: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RetroNick2020/raster-master-dos/51aa355531856ace663ac7eb4b65d02a39230bb7/RMCLIP/SVGA256.BGI -------------------------------------------------------------------------------- /RMCLIP/SVGA256.OBJ: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RetroNick2020/raster-master-dos/51aa355531856ace663ac7eb4b65d02a39230bb7/RMCLIP/SVGA256.OBJ -------------------------------------------------------------------------------- /RMCLIP/VARS.PAS: -------------------------------------------------------------------------------- 1 | 2 | Unit Vars; 3 | 4 | Interface 5 | uses RKey,DOS; 6 | const 7 | 8 | ProgramName = 'Raster Clip v2.1'; 9 | Copyright = '(c) Copyright 1993-2022 By RetroNick. All Rights Reserved.'; 10 | GitHub1 = 'Get source and latest version from github:'; 11 | GitHub2 = 'https://github.com/RetroNick2020'; 12 | 13 | Var 14 | _RCKey : KeyRec; 15 | CPath : String; 16 | 17 | Implementation 18 | 19 | Procedure GetPath; 20 | var 21 | n : nameStr; 22 | d : dirStr; 23 | e : extStr; 24 | BEGIN 25 | fsplit(ParamStr(0),d,n,e); 26 | Cpath:=d; 27 | end; 28 | 29 | begin 30 | GetPath; 31 | ReadKey(_RCKey,Cpath+'\RM.KEY'); 32 | end. 33 | -------------------------------------------------------------------------------- /RMCLIP/WPRF.PAS: -------------------------------------------------------------------------------- 1 | Unit WPRF; 2 | Interface 3 | uses dos,graph; 4 | Function WritePPR(x,y,x2,y2 : word; filename : string) : word; 5 | Function WriteSPR(x,y,x2,y2 : word; filename : string) : word; 6 | 7 | Implementation 8 | 9 | Function WritePPR(x,y,x2,y2 : word;filename:string):word; 10 | Var 11 | f : file; 12 | rc :byte; 13 | i,j : word; 14 | col : byte; 15 | lastcol : byte; 16 | myWidth : word; 17 | myHeight: word; 18 | nc : byte; 19 | cl : Array[1..3] of byte; 20 | error : word; 21 | myPprHeader : Array[1..24] of byte; 22 | begin 23 | {$I-} 24 | myWidth:=x2-x+1; 25 | myHeight:=y2-y+1; 26 | 27 | Fillchar(myPprHeader,24,0); 28 | 29 | myPprHeader[1]:=ORD('P'); 30 | myPprHeader[4]:=ORD('P'); 31 | myPprHeader[7]:=ORD('R'); 32 | 33 | myPprHeader[10]:=HI(myWidth); 34 | myPprHeader[13]:=LO(myWidth); 35 | 36 | myPprHeader[16]:=HI(myHeight); 37 | myPprHeader[19]:=LO(myHeight); 38 | 39 | myPPrHeader[22]:=4; 40 | 41 | assign(F,filename); 42 | rewrite(f,1); 43 | 44 | BlockWrite(F,myPprHeader,24); 45 | 46 | 47 | nc:=0; 48 | rc:=0; 49 | fillchar(cl,3,0); 50 | 51 | for j:=y2 downto y do 52 | begin 53 | for i:=x to x2 do 54 | begin 55 | col:=GetPixel(i,j); 56 | inc(rc); 57 | if rc=1 then 58 | begin 59 | Lastcol:=col; 60 | end 61 | else if col<>lastcol then 62 | begin 63 | inc(nc); 64 | if nc=1 then 65 | begin 66 | cl[1]:=(lastcol shl 4); 67 | cl[2]:=rc-1; 68 | end 69 | else if nc=2 then 70 | begin 71 | inc(cl[1],lastcol); 72 | cl[3]:=rc-1; 73 | nc:=0; 74 | Blockwrite(f,cl[1],3); 75 | fillchar(cl,3,0); 76 | end; 77 | rc:=1; 78 | lastcol:=col; 79 | end 80 | else if rc=255 then 81 | begin 82 | inc(nc); 83 | if nc=1 then 84 | begin 85 | cl[1]:=(col shl 4); 86 | cl[2]:=rc; 87 | end 88 | else if nc=2 then 89 | begin 90 | inc(cl[1],col); 91 | cl[3]:=rc; 92 | nc:=0; 93 | blockwrite(f,cl[1],3); 94 | fillchar(cl,3,0); 95 | end; 96 | rc:=0; 97 | end; 98 | end; 99 | 100 | 101 | error:=ioresult; 102 | if error<>0 then 103 | begin 104 | close(f); 105 | erase(f); 106 | WritePPR:=error; 107 | exit; 108 | end; 109 | 110 | 111 | end; 112 | if rc>0 then 113 | begin 114 | if nc=0 then 115 | begin 116 | cl[1]:=(col shl 4); 117 | cl[2]:=rc; 118 | cl[3]:=0; 119 | end 120 | else 121 | begin 122 | inc(cl[1],col); 123 | cl[3]:=rc; 124 | end; 125 | Blockwrite(f,cl,3); 126 | end; 127 | close(F); 128 | error:=IOresult; 129 | WritePPR:=error; 130 | {$I+} 131 | end; 132 | 133 | 134 | Function WriteSPR(x,y,x2,y2 : word;filename:string):word; 135 | Var 136 | f : file; 137 | rc : byte; 138 | i,j : word; 139 | col : byte; 140 | lastcol : byte; 141 | myWidth : word; 142 | myHeight: word; 143 | error : word; 144 | mySprHeader : Array[1..16] of byte; 145 | begin 146 | {$I-} 147 | 148 | myWidth:=x2-x+1; 149 | myHeight:=y2-y+1; 150 | 151 | Fillchar(mySprHeader,16,0); 152 | mySprHeader[1]:=ORD('S'); 153 | mySprHeader[3]:=ORD('P'); 154 | mySprHeader[5]:=ORD('R'); 155 | 156 | mySprHeader[7]:=HI(myWidth); 157 | mySprHeader[9]:=LO(myWidth); 158 | 159 | mySprHeader[11]:=HI(myHeight); 160 | mySprHeader[13]:=LO(myHeight); 161 | 162 | 163 | If GetMaxColor = 255 then 164 | begin 165 | mySprHeader[15]:=8; 166 | end 167 | else 168 | begin 169 | mySprHeader[15]:=4; 170 | end; 171 | assign(F,filename); 172 | rewrite(f,1); 173 | 174 | BlockWrite(F,mySprHeader,16); 175 | 176 | rc:=0; 177 | for j:=y2 downto y do 178 | begin 179 | for i:=x to x2 do 180 | begin 181 | col:=GetPixel(i,j); 182 | inc(rc); 183 | if rc=1 then 184 | begin 185 | Lastcol:=col; 186 | end 187 | else if col<>lastcol then 188 | begin 189 | Blockwrite(f,lastcol,1); 190 | dec(rc); 191 | Blockwrite(f,rc,1); 192 | rc:=1; 193 | lastcol:=col; 194 | end 195 | else if rc=255 then 196 | begin 197 | blockwrite(f,col,1); 198 | blockwrite(f,rc,1); 199 | rc:=0; 200 | end; 201 | end; 202 | 203 | error:=ioresult; 204 | if error<>0 then 205 | begin 206 | close(f); 207 | erase(f); 208 | WriteSPR:=error; 209 | exit; 210 | end; 211 | 212 | end; 213 | if rc>0 then 214 | begin 215 | blockwrite(f,col,1); 216 | blockwrite(f,rc,1); 217 | end; 218 | close(F); 219 | error:=ioresult; 220 | WriteSPR:=error; 221 | {$I+} 222 | end; 223 | 224 | begin 225 | end. -------------------------------------------------------------------------------- /RMCLIP/WXGF.PAS: -------------------------------------------------------------------------------- 1 | Unit wXgf; 2 | Interface 3 | uses xgraph,graph,bits; 4 | 5 | Function WriteXgf(x,y,x2,y2,LanType :Word;Filename : String) : Word; 6 | Function ReadICN(x,y,x2,y2 : Word;Filename : String) : Word; 7 | 8 | 9 | Implementation 10 | 11 | type 12 | linebuftype = array[0..1023] of byte; 13 | 14 | 15 | Function WriteXgf(x,y,x2,y2,LanType :Word;Filename : String) : Word; 16 | Type 17 | ImgRec = Array[1..$FFFF] of Byte; 18 | 19 | Var 20 | myWidth,myHeight : Word; 21 | F : File; 22 | Error : Word; 23 | BytesPerLine : Word; 24 | size : LongInt; 25 | ImgBuf : ^ImgRec; 26 | i,j : Word; 27 | BitPlane2,bitPlane3,BitPlane4 : Word; 28 | temp : byte; 29 | Uline : array[0..2047] of byte; 30 | sig : array[1..2] of char; 31 | begin 32 | Error:=0; 33 | Size:=xgraph.imagesize(x,0,x2,0); 34 | BytesPerLine:=Size-6; 35 | 36 | myWidth:=x2-x+1; 37 | myHeight:=y2-y+1; 38 | 39 | 40 | If (GetMaxColor=15) and (lantype=2) then 41 | begin 42 | BitPlane2:=(BytesPerLine SHR 2); 43 | BitPlane3:=(BytesPerLine SHR 1); 44 | BitPlane4:=(BytesPerLine SHR 2) * 3; 45 | end; 46 | 47 | 48 | If (LanType=1) then 49 | begin 50 | Dec(mywidth,1); 51 | Dec(myheight,1); 52 | end 53 | else if (GetMaxColor=255) and (LanType=2) then 54 | begin 55 | myWidth:=mywidth*8; 56 | end; 57 | 58 | {$I-} 59 | Assign(F,FileName); 60 | Rewrite(F,1); 61 | Error:=IOResult; 62 | If Error <> 0 then 63 | begin 64 | WriteXgf:=Error; 65 | exit; 66 | end; 67 | BlockWrite(F,myWidth,2); 68 | BlockWrite(F,myHeight,2); 69 | GetMem(imgBuf,size); 70 | For i:=y to y2 do 71 | begin 72 | GetImage(x,i,x2,i,ImgBuf^); 73 | Move(ImgBuf^[5],ULine[0],BytesPerLine); 74 | 75 | if (LanType=2) AND (GetMaxColor=15) then 76 | begin 77 | For j:=0 to BitPlane2-1 do 78 | begin 79 | Temp:=Uline[j]; 80 | Uline[j]:=Uline[j+BitPlane4]; 81 | Uline[j+BitPlane4]:=Temp; 82 | Temp:=Uline[j+BitPlane2]; 83 | Uline[j+BitPlane2]:=Uline[j+BitPlane3]; 84 | Uline[j+BitPlane3]:=Temp; 85 | end; 86 | end; 87 | BlockWrite(F,uline,BytesPerLine); 88 | Error:=IOResult; 89 | If Error <> 0 then 90 | begin 91 | WriteXgf:=Error; 92 | FreeMem(ImgBuf,size); 93 | exit; 94 | end; 95 | end; 96 | if Lantype=1 then 97 | begin 98 | Sig:='RM'; 99 | BlockWrite(F,sig,sizeof(sig)); 100 | end; 101 | Close(F); 102 | Error:=IOResult; 103 | {$I+} 104 | If Error <> 0 then 105 | begin 106 | WriteXgf:=Error; 107 | FreeMem(ImgBuf,size); 108 | exit; 109 | end; 110 | WriteXgf:=Error; 111 | end; 112 | 113 | Procedure mpTOsp(Var mPlane : Linebuftype;Var splane : Linebuftype; 114 | ImgOff2,ImgOff3,ImgOff4 : Word); 115 | Var 116 | i,j : Word; 117 | xpos : Word; 118 | Col : Word; 119 | begin 120 | xpos:=0; 121 | FillChar(splane,SizeOf(sPlane),0); 122 | For i:=0 to ImgOff2-1 do 123 | begin 124 | For j:=7 downto 0 do 125 | begin 126 | Col:=0; 127 | if biton(j,mPlane[i]) then 128 | begin 129 | Inc(Col,1); 130 | end; 131 | 132 | if biton(j,mPlane[i+ImgOff2]) then 133 | begin 134 | Inc(Col,2); 135 | end; 136 | 137 | if biton(j,mPlane[i+ImgOff3]) then 138 | begin 139 | Inc(Col,4); 140 | end; 141 | 142 | if biton(j,mPlane[i+ImgOff4]) then 143 | begin 144 | Inc(Col,8); 145 | end; 146 | 147 | Splane[xpos]:=Col; 148 | Inc(xpos); 149 | end; 150 | end; 151 | end; 152 | 153 | Function ReadICN(x,y,x2,y2 : Word;Filename : String) : Word; 154 | Type 155 | XgfHead = Record 156 | Width : Word; 157 | Height : Word; 158 | End; 159 | 160 | Var 161 | uline,sline : Linebuftype; 162 | myHead : XgfHead; 163 | mywidth : word; 164 | myheight : word; 165 | myFSize, 166 | FSize16, 167 | Fsize256 : Longint; 168 | BPL,BitPlane2,BitPlane3,BitPlane4 : Word; 169 | F : File; 170 | Error : Word; 171 | Temp : Word; 172 | J,I : Word; 173 | ICN16 : Boolean; 174 | 175 | begin 176 | {$I-} 177 | Assign(F,Filename); 178 | Reset(F,1); 179 | myFSize:=FileSize(F); 180 | Error:=IORESULT; 181 | If Error<>0 then 182 | begin 183 | ReadICN:=Error; 184 | exit; 185 | end; 186 | 187 | 188 | BlockRead(F,myHead,sizeof(myHead)); 189 | inc(myHead.width); 190 | inc(myHead.Height); 191 | 192 | myWidth:=x2-x+1; 193 | myheight:=y2-y+1; 194 | 195 | if myWidth > myHead.width then myWidth:=myHead.width; 196 | if myHeight > myHead.Height then myHeight:=myHead.Height; 197 | 198 | FSize16:=((myHead.width+7) div 8) * 4 * myhead.height+6; 199 | FSize256:=myHead.width * myhead.height+6; 200 | 201 | If myFSize=Fsize16 then 202 | begin 203 | ICN16:=TRUE; 204 | BPL:=((myHead.width+7) div 8) * 4; 205 | BitPlane2:=(BPL SHR 2); 206 | BitPlane3:=(BPL SHR 1); 207 | BitPlane4:=(BPL SHR 2) * 3; 208 | end 209 | else if myFSize=Fsize256 then 210 | begin 211 | ICN16:=FALSE; 212 | BPL:=LongInt(myHead.width) 213 | end 214 | else 215 | begin 216 | ReadICN:=1000; 217 | Close(F); 218 | Error:=IORESULT; 219 | exit; 220 | end; 221 | 222 | For j:=1 to myheight do 223 | begin 224 | If ICN16 then 225 | begin 226 | BlockRead(F,uline,BPL); 227 | For I:=0 to BitPlane2-1 do 228 | begin 229 | Temp:=Uline[I]; 230 | Uline[I]:=Uline[I+BitPlane4]; 231 | Uline[I+BitPlane4]:=Temp; 232 | Temp:=Uline[I+BitPlane2]; 233 | Uline[I+BitPlane2]:=Uline[I+BitPlane3]; 234 | Uline[I+BitPlane3]:=Temp; 235 | end; 236 | mpToSp(uline,sline,BitPlane2,BitPlane3,BitPlane4); 237 | end 238 | else 239 | begin 240 | BlockRead(F,sline,BPL); 241 | end; 242 | 243 | For i:=1 to myWidth do 244 | begin 245 | PutPixel(x+i-1,y+j-1,sline[i-1]); 246 | end; 247 | 248 | end; 249 | 250 | Close(F); 251 | Error:=IORESULT; 252 | ReadICN:=Error; 253 | {$I+} 254 | end; 255 | 256 | 257 | 258 | begin 259 | end. -------------------------------------------------------------------------------- /RMCLIP/XGRAPH.PAS: -------------------------------------------------------------------------------- 1 | Unit XGraph; (* some things to fix *) 2 | Interface 3 | uses graph; 4 | 5 | Function ImageSize(x,y,x2,y2 : longint) : LongInt; 6 | 7 | Implementation 8 | 9 | Function ImageSize(x,y,x2,y2 : longint) : LongInt; 10 | begin 11 | if GetMaxColor = 255 then 12 | begin 13 | ImageSize:=6+(x2-x+1)*(y2-y+1); 14 | end 15 | else 16 | begin 17 | ImageSize:=graph.ImageSize(x,y,x2,y2); 18 | end; 19 | end; 20 | 21 | begin 22 | end. -------------------------------------------------------------------------------- /RP/PCX2XGF.PAS: -------------------------------------------------------------------------------- 1 | Program pcx2xgf; 2 | uses DOS,PCX2RAW,RAW2XGF,RAW2DEF,RAW2PRF,Keys; 3 | 4 | Const 5 | TPLan = 1; 6 | TCLan = 2; 7 | QCLan = 3; 8 | QBLan = 4; 9 | PBLan = 5; 10 | GWLan = 6; 11 | 12 | Binary2 = 1; 13 | Binary4 = 2; 14 | Binary16 = 3; 15 | Binary256 = 4; 16 | 17 | Source2 = 5; 18 | Source4 = 6; 19 | Source16 = 7; 20 | Source256 = 8; 21 | 22 | SPRBinary = 9; 23 | SPRSource = 10; 24 | 25 | PPRBinary = 11; 26 | PPRSource = 12; 27 | 28 | TEGLText = 13; 29 | 30 | Const 31 | Compilers : array[1..6] of String = ('Turbo Pascal','Turbo C','QuickC', 32 | 'QuickBASIC','Power Basic','GW BASIC'); 33 | 34 | myNumColors : array[1..4] of Word = (2,4,16,256); 35 | Var 36 | 37 | myPcxPalette : PcxPalette; 38 | myPcxHeader : PcxHeader; 39 | myWidth : Word; 40 | myHeight : Word; 41 | myNColors : Word; 42 | myMemAmount : LongInt; 43 | myReply : String[1]; 44 | myPcxFile : String; 45 | myXgfFile : String; 46 | myFormat : Word; 47 | myCompiler : Word; 48 | Error : Word; 49 | F : File; 50 | 51 | 52 | 53 | Function FileExists(filename:string) : Boolean; 54 | var f : file; 55 | begin 56 | {$I-} 57 | Assign(f,FileName); 58 | Reset(f); 59 | Close(f); 60 | 61 | FileExists:=(IOResult=0) and (Filename<>''); 62 | {$I+} 63 | end; 64 | 65 | Function MemRequired(Width,Height,Comp,Format : Longint) : Longint; 66 | Var 67 | myMem : longint; 68 | begin 69 | Case Format of Binary2,Source2:begin 70 | myMem:=((Width+7) div 8) * Height+4; 71 | end; 72 | Binary4,Source4:begin 73 | myMem:=((Width+7) div 8) * 2 * Height+4; 74 | end; 75 | Binary16,Source16:begin 76 | myMem:=((Width+7) div 8) * 4 * Height+4; 77 | end; 78 | Binary256,Source256:begin 79 | myMem:=Width * Height+4; 80 | end; 81 | 82 | end; 83 | 84 | Case Comp of TPLan,TCLan:begin 85 | inc(myMem,2); 86 | end; 87 | GWLan,PBLan,QBLan:begin 88 | if Odd(myMem) then 89 | begin 90 | inc(myMem); 91 | end; 92 | end; 93 | end; 94 | MemRequired:=myMem; 95 | end; 96 | 97 | Function GetFormType(FormStr : String;Var myFormat,myCompiler : Word) : Boolean; 98 | Var 99 | i : Word; 100 | lanStr : String; 101 | ColStr : String; 102 | begin 103 | GetFormType:=True; 104 | if FormStr[1]='-' then 105 | begin 106 | Delete(FormStr,1,1); 107 | End; 108 | For i:=1 to Length(FormStr) do 109 | begin 110 | FormStr[i]:=UpCase(FormStr[i]); 111 | 112 | End; 113 | 114 | If FormStr='PPR' then 115 | begin 116 | myFormat:=PPRBinary; 117 | end 118 | Else if FormStr='SPR' then 119 | begin 120 | myFormat:=SPRBinary; 121 | end 122 | Else if FormStr='DEF' then 123 | begin 124 | myFormat:=TeglText; 125 | end 126 | Else 127 | begin 128 | LanStr:=FormStr[1]+FormStr[2]; 129 | Delete(FormStr,1,2); 130 | Colstr:=FormStr; 131 | 132 | IF LanStr='TP' then 133 | begin 134 | myCompiler:=TPLan; 135 | end 136 | Else If LanStr='TC' then 137 | begin 138 | myCompiler:=TCLan; 139 | end 140 | Else If LanStr='QC' then 141 | begin 142 | myCompiler:=QCLan; 143 | end 144 | Else If LanStr='QB' then 145 | begin 146 | myCompiler:=QBLan; 147 | end 148 | Else IF LanStr='PB' then 149 | begin 150 | myCompiler:=PBLan; 151 | end 152 | Else If LanStr='GW' then 153 | begin 154 | myCompiler:=GWLan; 155 | end 156 | Else 157 | begin 158 | GetFormType:=False; 159 | Exit; 160 | End; 161 | 162 | If ColStr='2' then 163 | begin 164 | myFormat:=Binary2; 165 | end 166 | Else if ColStr='4' then 167 | begin 168 | myFormat:=Binary4; 169 | end 170 | Else if ColStr='16' then 171 | begin 172 | myFormat:=Binary16; 173 | end 174 | Else if ColStr='256' then 175 | begin 176 | myFormat:=Binary256; 177 | end 178 | else 179 | begin 180 | GetFormType:=False; 181 | exit; 182 | end; 183 | End; 184 | 185 | End; 186 | 187 | 188 | begin 189 | If ParamCount<>3 then 190 | begin 191 | WriteLn('RastPort V1.0'); 192 | WriteLn('Usage: RastPort -format'); 193 | WriteLn; 194 | WriteLn(' In_File = PCX File to read'); 195 | WriteLn(' Out_FIle = XGF File to create'); 196 | WriteLn(' Format = TPx,TCx,QCx,QBx,PBx,SPR,PPR'); 197 | WriteLn(' x can be 2,4,16, or 256'); 198 | WriteLn; 199 | 200 | Halt(1); 201 | End; 202 | 203 | 204 | 205 | myPcxFile:=ParamStr(1); 206 | myXgfFile:=ParamStr(2); 207 | 208 | 209 | if FileExists(myPcxFile)=false then 210 | begin 211 | WriteLn(myPcxFile,' does not exist!'); 212 | Halt; 213 | end; 214 | 215 | if FileExists(myXgfFile) then 216 | begin 217 | Repeat 218 | Write('File Already Exists. Overwrite? [y/n]'); 219 | Readln(myReply); 220 | myReply:=UpCase(myReply[1]); 221 | if myReply='N' then 222 | begin 223 | Halt; 224 | end; 225 | Until (myReply='Y'); 226 | end; 227 | 228 | 229 | 230 | If ValidPcxFile(myPcxFile) = False then 231 | begin 232 | WriteLn('Invalid PCX file!'); 233 | Halt(1); 234 | end; 235 | 236 | 237 | If GetFormType(ParamStr(3),myFormat,myCompiler) = False then 238 | begin 239 | WriteLn('Invalid output format!'); 240 | Halt; 241 | End; 242 | 243 | 244 | 245 | GetPcxInfo(myPcxFile,myPcxHeader,myPcxPalette); 246 | myWidth :=GetPcxWidth(myPcxHeader); 247 | myHeight:=GetPcxHeight(myPcxHeader); 248 | myNColors:=GetNPcxColors(myPcxHeader); 249 | WriteLn('Width= ',myWidth,' Height= ',myHeight,' Colors= ',myNColors); 250 | 251 | 252 | Case myFormat Of Binary2..Binary256: 253 | begin 254 | If (myNColors>myNumColors[myFormat]) then 255 | begin 256 | Repeat 257 | Write('Color values will be truncated. Continue Anyway? [y/n]'); 258 | Readln(myReply); 259 | myReply:=UpCase(myReply[1]); 260 | if myReply='N' then 261 | begin 262 | Halt; 263 | end; 264 | Until (myReply='Y') 265 | end; 266 | 267 | Writeln('PCX --> ',myNumColors[myFormat],' Color Bitmap for ',Compilers[myCompiler],'.'); 268 | myMemAmount:=MemRequired(myWidth,myHeight,myCompiler,myFormat); 269 | If myMemAmount > $FFFF then 270 | begin 271 | Repeat 272 | Write('File will exceed 64K. Continue Anyway? [y/n]'); 273 | Readln(myReply); 274 | myReply:=UpCase(myReply[1]); 275 | if myReply='N' then 276 | begin 277 | Halt; 278 | end; 279 | Until (myReply='Y') 280 | end; 281 | Error:=PcxToRaw(myPcxfile,'$$$$.Raw'); 282 | Error:=RawToXgf('$$$$.Raw',myXgfFile,myNumColors[myFormat],myCompiler); 283 | End; 284 | SPRBinary: 285 | begin 286 | Writeln('PCX --> SPR'); 287 | Error:=PcxToRaw(myPcxfile,'$$$$.Raw'); 288 | error:=RawToSpr('$$$$.raw',myXgfFile); 289 | end; 290 | PPRBinary: 291 | begin 292 | If myNColors>16 then 293 | begin 294 | Repeat 295 | Write('Color values will be truncated. Continue Anyway? [y/n]'); 296 | Readln(myReply); 297 | myReply:=UpCase(myReply[1]); 298 | if myReply='N' then 299 | begin 300 | Halt; 301 | end; 302 | Until (myReply='Y') 303 | end; 304 | Writeln('PCX --> PPR'); 305 | Error:=PcxToRaw(myPcxfile,'$$$$.Raw'); 306 | error:=RawToPpr('$$$$.raw',myXgfFile); 307 | end; 308 | TeglText: 309 | begin 310 | If myNColors>16 then 311 | begin 312 | Repeat 313 | Write('Color values will be truncated. Continue Anyway? [y/n]'); 314 | Readln(myReply); 315 | myReply:=UpCase(myReply[1]); 316 | if myReply='N' then 317 | begin 318 | Halt; 319 | end; 320 | Until (myReply='Y') 321 | end; 322 | Writeln('PCX --> DEF'); 323 | Error:=PcxToRaw(myPcxfile,'$$$$.Raw'); 324 | error:=RawToDEF('$$$$.raw',myXgfFile); 325 | end; 326 | End; 327 | 328 | Assign(F,'$$$$.raw'); 329 | Erase(F); 330 | 331 | End. 332 | -------------------------------------------------------------------------------- /RP/RAW2DEF.PAS: -------------------------------------------------------------------------------- 1 | Unit RAW2DEF; 2 | Interface 3 | uses Dos; 4 | Function RawToDef(rawFile,defFile : string) : Word; 5 | Implementation 6 | 7 | Procedure Byte2str(mybyte : byte;Var mystring :string); 8 | const 9 | hexa : array[0..15] of char=('0','1','2','3','4','5','6','7','8','9', 10 | 'A','B','C','D','E','F'); 11 | var 12 | h1,h2 : byte; 13 | begin 14 | h2:=mybyte shl 4; 15 | h2:=h2 shr 4; 16 | mystring:=hexa[h2]; 17 | end; 18 | 19 | Function RawToDef(rawFile,defFile : string) : Word; 20 | Var 21 | F : Text; 22 | F2: File; 23 | Width : Word; 24 | Height: Word; 25 | Col : Word; 26 | I,J : WOrd; 27 | myCol : byte; 28 | mySCol: String; 29 | myBuf : Array[1..1024] of char; 30 | myPal : array[1..768] of byte; 31 | begin 32 | Assign(F,defFile); 33 | Rewrite(F); 34 | SetTextBuf(F,myBuf); 35 | 36 | Assign(F2,rawFile); 37 | Reset(F2,1); 38 | 39 | Blockread(F2,Width,2); 40 | Blockread(F2,Height,2); 41 | Blockread(F2,Col,2); 42 | Blockread(F2,myPal,Col*3); 43 | 44 | Write('Converting RAW To DEF. Processing Line: '); 45 | 46 | For J:=1 to Height Do 47 | begin 48 | Write(#8,#8,#8,#8); 49 | Write(J:4); 50 | For I:=1 to Width Do 51 | begin 52 | BlockRead(F2,myCol,1); 53 | Byte2Str(myCol,mySCol); 54 | Write(F,mySCol); 55 | end; 56 | WriteLN(F); 57 | End; 58 | 59 | Close(F); 60 | Close(F2); 61 | 62 | RawToDef:=IOResult; 63 | End; 64 | 65 | begin 66 | end. 67 | -------------------------------------------------------------------------------- /RP/RAW2PRF.PAS: -------------------------------------------------------------------------------- 1 | Unit RAW2PRF; 2 | Interface 3 | uses Dos; 4 | Function RawToSpr(RawFile, SprFile : string) : word; 5 | Function RawToPPR(RawFile,PPRfile:string):word; 6 | 7 | Implementation 8 | Function RawToSpr(RawFile, SprFile : string) : word; 9 | Var 10 | f: file; 11 | f2: file; 12 | rc:byte; 13 | i,j : word; 14 | col : byte; 15 | lastcol:byte; 16 | myWidth:word; 17 | myHeight:word; 18 | 19 | error : word; 20 | myRawWidth : Word; 21 | myRawheight : Word; 22 | myRawCol : byte; 23 | myDumWord : Word; 24 | myFsize : longint; 25 | myBuf : Array[1..1024] of byte; 26 | mySprHeader : Array[1..16] of byte; 27 | myPal : Array[1..768] of byte; 28 | begin 29 | {$I-} 30 | 31 | Assign(F2,RawFile); 32 | Reset(F2,1); 33 | 34 | Blockread(F2,myRawWidth,2); 35 | Blockread(F2,myRawHeight,2); 36 | Blockread(F2,myDumWord,2); 37 | Blockread(F2,myPal,myDumWord*3); 38 | 39 | FillChar(mySprHeader,16,0); 40 | 41 | mySprHeader[1]:=ORD('S'); 42 | mySprHeader[3]:=ORD('P'); 43 | mySprHeader[5]:=ORD('R'); 44 | 45 | mySprHeader[7]:=HI(myRawWidth); 46 | mySprHeader[9]:=LO(myRawWidth); 47 | 48 | mySprHeader[11]:=HI(myRawHeight); 49 | mySprHeader[13]:=LO(myRawHeight); 50 | 51 | mySprHeader[15]:=8; 52 | 53 | assign(F,SprFile); 54 | rewrite(f,1); 55 | BlockWrite(F,mySprHeader,16); 56 | rc:=0; 57 | 58 | Write(' RAW To SPR. Processing Line: '); 59 | 60 | 61 | for j:=myrawHeight downto 1 do 62 | begin 63 | Write(#8,#8,#8,#8); 64 | Write((myrawHeight-J+1):4); 65 | 66 | myFsize:=6+(mydumword*3)+(LongInt(J)-1)*LongInt(myRawWidth); 67 | Seek(F2,myFsize); 68 | BlockRead(F2,myBuf,myRawWidth); 69 | 70 | for i:=1 to myRawWidth do 71 | begin 72 | (* BlockRead(F2,col,1);*) 73 | Col:=myBuf[i]; 74 | inc(rc); 75 | if rc=1 then 76 | begin 77 | Lastcol:=col; 78 | end 79 | else if col<>lastcol then 80 | begin 81 | Blockwrite(f,lastcol,1); 82 | dec(rc); 83 | Blockwrite(f,rc,1); 84 | rc:=1; 85 | lastcol:=col; 86 | end 87 | else if rc=255 then 88 | begin 89 | blockwrite(f,col,1); 90 | blockwrite(f,rc,1); 91 | rc:=0; 92 | end; 93 | end; 94 | Error:=IORESULT; 95 | If Error<>0 then 96 | begin 97 | RawToSPr:=Error; 98 | Exit; 99 | end; 100 | end; 101 | 102 | if rc>0 then 103 | begin 104 | blockwrite(f,col,1); 105 | blockwrite(f,rc,1); 106 | end; 107 | WriteLn; 108 | Close(F); 109 | Close(F2); 110 | error:=ioresult; 111 | RawToSpr:=error; 112 | {$I+} 113 | end; 114 | 115 | Function RawToPPR(RawFile,PPRfile:string):word; 116 | Var 117 | f: file; 118 | F2 : File; 119 | rc:byte; 120 | i,j : word; 121 | col : byte; 122 | lastcol:byte; 123 | myWidth:word; 124 | myHeight:word; 125 | nc : byte; 126 | cl : array[1..3] of byte; 127 | myRawWidth : Word; 128 | myRawheight: Word; 129 | myRawCol : byte; 130 | myDumWord : Word; 131 | myFsize : longint; 132 | myBuf : Array[1..1024] of byte; 133 | myPprHeader : Array[1..24] of byte; 134 | myColors : Word; 135 | error : word; 136 | myPal : Array[1..768] of byte; 137 | begin 138 | {$I-} 139 | Assign(F2,RawFile); 140 | Reset(F2,1); 141 | 142 | Blockread(F2,myRawWidth,2); 143 | Blockread(F2,myRawHeight,2); 144 | Blockread(F2,myDumWord,2); 145 | Blockread(F2,myPal,myDumWord*3); 146 | 147 | FillChar(myPprHeader,24,0); 148 | 149 | myPprHeader[1]:=ORD('P'); 150 | myPprHeader[4]:=ORD('P'); 151 | myPprHeader[7]:=ORD('R'); 152 | 153 | myPprHeader[10]:=HI(myRawWidth); 154 | myPprHeader[13]:=LO(myRawWidth); 155 | 156 | myPprHeader[16]:=HI(myRawHeight); 157 | myPprHeader[19]:=LO(myRawHeight); 158 | 159 | myPprHeader[22]:=4; 160 | 161 | 162 | assign(F,PPRfile); 163 | rewrite(f,1); 164 | BlockWrite(F,myPprHeader,24); 165 | 166 | nc:=0; 167 | rc:=0; 168 | fillchar(cl,3,0); 169 | 170 | 171 | Write(' RAW To PPR. Processing Line: '); 172 | 173 | for j:=myrawHeight downto 1 do 174 | begin 175 | Write(#8,#8,#8,#8); 176 | Write((myrawHeight-J+1):4); 177 | 178 | myFsize:=6+(mydumword*3)+(LongInt(J)-1)*LongInt(myRawWidth); 179 | Seek(F2,myFsize); 180 | BlockRead(F2,myBuf,myRawWidth); 181 | 182 | for i:=1 to myRawWidth do 183 | begin 184 | Col:=myBuf[i]; 185 | inc(rc); 186 | if rc=1 then 187 | begin 188 | Lastcol:=col; 189 | end 190 | else if col<>lastcol then 191 | begin 192 | inc(nc); 193 | if nc=1 then 194 | begin 195 | cl[1]:=(lastcol shl 4); 196 | cl[2]:=rc-1; 197 | end 198 | else if nc=2 then 199 | begin 200 | inc(cl[1],lastcol); 201 | cl[3]:=rc-1; 202 | nc:=0; 203 | Blockwrite(f,cl[1],3); 204 | fillchar(cl,3,0); 205 | end; 206 | rc:=1; 207 | lastcol:=col; 208 | end 209 | else if rc=255 then 210 | begin 211 | inc(nc); 212 | if nc=1 then 213 | begin 214 | cl[1]:=(col shl 4); 215 | cl[2]:=rc; 216 | end 217 | else if nc=2 then 218 | begin 219 | inc(cl[1],col); 220 | cl[3]:=rc; 221 | nc:=0; 222 | blockwrite(f,cl[1],3); 223 | fillchar(cl,3,0); 224 | end; 225 | rc:=0; 226 | end; 227 | end; 228 | Error:=IORESULT; 229 | If Error<>0 then 230 | begin 231 | RawToPPr:=Error; 232 | Exit; 233 | end; 234 | 235 | end; 236 | if rc>0 then 237 | begin 238 | if nc=0 then 239 | begin 240 | cl[1]:=(col shl 4); 241 | cl[2]:=rc; 242 | cl[3]:=0; 243 | end 244 | else 245 | begin 246 | inc(cl[1],col); 247 | cl[3]:=rc; 248 | end; 249 | blockwrite(f,cl,3); 250 | end; 251 | WriteLn; 252 | close(F); 253 | Close(F2); 254 | error:=IOresult; 255 | RawToPPR:=error; 256 | {$I+} 257 | end; 258 | 259 | begin 260 | end. 261 | -------------------------------------------------------------------------------- /RP/RAW2XGF.PAS: -------------------------------------------------------------------------------- 1 | Unit Raw2XGF; 2 | 3 | Interface 4 | Uses Dos,PCX2RAW; 5 | 6 | Function RawToXgf(RawFileName,XgfFileName : String;MaxColors,CompLan: Word) : Word; 7 | 8 | Implementation 9 | Type 10 | LineBufType = Array[0..1023] Of Byte; 11 | ColorMap = Array[0..15] of Byte; 12 | 13 | Const 14 | TPLan = 1; 15 | TCLan = 2; 16 | QCLan = 3; 17 | QBLan = 4; 18 | PBLan = 5; 19 | GWLan = 6; 20 | 21 | BColorMap : ColorMap = (0,8,4,12,2,10,6,14,1,9,5,13,3,11,7,15); 22 | MSColorMap: ColorMap = (0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15); 23 | 24 | Var 25 | DefaultColorMap : ColorMap; 26 | 27 | Function BitOn(Position,Testbyte : Byte) : Boolean; 28 | Var 29 | Bt : Byte; 30 | Begin 31 | Bt :=$01; 32 | Bt :=Bt Shl Position; 33 | Biton :=(Bt And Testbyte) > 0; 34 | End; 35 | 36 | Procedure SetBit(Position, Value : Byte; Var Changebyte : Byte); 37 | Var 38 | Bt : Byte; 39 | Begin 40 | Bt :=$01; 41 | Bt :=Bt Shl Position; 42 | If Value = 1 then 43 | Changebyte :=Changebyte Or Bt 44 | Else 45 | Begin 46 | Bt :=Bt Xor $FF; 47 | Changebyte :=Changebyte And Bt; 48 | End; 49 | End; 50 | 51 | Function StackLine16(Width : Word;Var LineBuf : LineBufType; 52 | Var StackedLine: LineBufType) : Word; 53 | var 54 | nb : Word; 55 | x : Word; 56 | np : Word; 57 | cl : Byte; 58 | cb : Byte; 59 | cp : Word; 60 | lof : Word; 61 | lof2 : Word; 62 | lof3 : Word; 63 | lof4 : Word; 64 | J : Word; 65 | xp : Word; 66 | begin 67 | nb :=(Width+7) div 8; 68 | FillChar(StackedLine,nb*4,0); 69 | lof :=0; 70 | lof2:=nb; 71 | lof3:=nb*2; 72 | lof4:=nb*3; 73 | xp:=0; 74 | cp:=0; 75 | for x:=0 to nb-1 do 76 | begin 77 | for j:=0 to 7 do 78 | begin 79 | cl:=DefaultColorMap[LineBuf[xp+j]]; 80 | Case biton(3,cl) Of True: Setbit((7-j),1,Stackedline[lof4+cp]) End; 81 | Case biton(2,cl) Of True: Setbit((7-j),1,StackedLine[lof3+cp]) End; 82 | Case biton(1,cl) Of True: Setbit((7-j),1,StackedLine[lof2+cp]) End; 83 | Case biton(0,cl) Of True: Setbit((7-j),1,StackedLine[lof+cp]) End; 84 | end; 85 | inc(cp); 86 | inc(xp,8); 87 | end; 88 | StackLine16:=nb*4; 89 | end; 90 | 91 | Procedure Pack4(Col1,Col2,Col3,Col4 : byte;Var PCol:byte); 92 | begin 93 | col1:=col1 shl 6; 94 | col2:=col2 shl 6; 95 | col2:=col2 shr 2; 96 | col3:=col3 shl 6; 97 | col3:=col3 shr 4; 98 | col4:=col4 shl 6; 99 | col4:=col4 shr 6; 100 | Pcol:=col1+col2+col3+col4; 101 | end; 102 | 103 | Function PackLine4(Width : Word;Var LineBuf : LineBufType; 104 | Var PackedLine : LineBufType) : Word; 105 | Var 106 | Count : Word; 107 | I : Word; 108 | C2 : Word; 109 | Begin 110 | Count :=0; 111 | I :=0; 112 | For I:=0 To ((Width+3) Div 4)-1 Do 113 | Begin 114 | Pack4(LineBuf[Count],LineBuf[Count+1],LineBuf[Count+2],LineBuf[Count+3], 115 | PackedLine[I]); 116 | Inc(Count,4); 117 | End; 118 | PackLine4:=(Width+3) Div 4; 119 | End; 120 | 121 | 122 | Function StackLine2(Width : Word;Var LineBuf : LineBufType; 123 | Var StackedLine: LineBufType) : Word; 124 | var 125 | nb : Word; 126 | x : Word; 127 | np : Word; 128 | cl : Byte; 129 | cb : Byte; 130 | cp : Word; 131 | lof : Word; 132 | J : Word; 133 | xp : Word; 134 | begin 135 | nb :=(Width+7) div 8; 136 | FillChar(StackedLine,nb,0); 137 | lof :=0; 138 | xp:=0; 139 | cp:=0; 140 | for x:=0 to nb-1 do 141 | begin 142 | for j:=0 to 7 do 143 | begin 144 | cl:=LineBuf[xp+j]; 145 | Case biton(0,cl) Of True: Setbit((7-j),1,StackedLine[lof+cp]) End; 146 | end; 147 | inc(cp); 148 | inc(xp,8); 149 | end; 150 | StackLine2:=nb; 151 | end; 152 | 153 | 154 | Function ShouldPad(Width,Height,Ncolors : Word) : Boolean; 155 | Var 156 | Temp : Word; 157 | begin 158 | ShouldPad:=False; 159 | Case Ncolors of 2,16 : Temp:=((Width+7) div 8)*Height; 160 | 4 : Temp:=((Width+3) div 4)*Height; 161 | 256 : Temp:=Width*Height; 162 | End; 163 | If Odd(Temp) then ShouldPad:=True; 164 | end; 165 | 166 | 167 | 168 | Function RawToXgf(RawFileName,XgfFileName : String;MaxColors,CompLan: Word) : Word; 169 | Const 170 | Dummy : Word = 0; 171 | Var 172 | RawFile,XgfFile : File; 173 | MyWidth,MyHeight: Word; 174 | Error : Word; 175 | MyCol : Word; 176 | RawLine : LineBufType; 177 | FormatedLine : LineBufType; 178 | J : Word; 179 | Nb : Word; 180 | t : Word; 181 | myPal : Array[1..768] of byte; 182 | begin 183 | DefaultColorMap:=MSColorMap; 184 | Assign(RawFile,RawFileName); 185 | Reset(RawFile,1); 186 | 187 | BlockRead(RawFile,MyWidth,2); 188 | BlockRead(RawFile,MyHeight,2); 189 | BlockRead(RawFile,MyCol,2); 190 | Blockread(RawFile,myPal,myCol*3); 191 | 192 | Assign(XgfFile,XgfFilename); 193 | Rewrite(XgfFile,1); 194 | 195 | Case CompLan of 196 | TPLan,TCLan:begin 197 | Dec(MyWidth); 198 | Dec(MyHeight); 199 | 200 | BlockWrite(XgfFile,MyWidth,2); 201 | BlockWrite(XgfFile,MyHeight,2); 202 | 203 | Inc(MyWidth); 204 | Inc(MyHeight); 205 | 206 | case MaxColors of 16 : DefaultColorMap:=BColorMAp; End; 207 | end; 208 | GWLan,QCLan,QBLan,PBLan:begin 209 | If MaxColors=256 then 210 | begin 211 | T:=MyWidth SHL 3; 212 | BlockWrite(XgfFile,T,2); 213 | end 214 | else 215 | begin 216 | BlockWrite(XgfFile,MyWidth,2); 217 | end; 218 | 219 | BlockWrite(XgfFile,MyHeight,2); 220 | If (MaxColors=16) then DefaultColorMap:=MSColorMap; 221 | If (MaxColors=16) And (CompLan=PBLan) then DefaultColorMap:=BColorMAp; 222 | 223 | end; 224 | end; 225 | 226 | Write(' RAW To XGF. Processing Line: '); 227 | 228 | For J:=1 to MyHeight Do 229 | begin 230 | Write(#8,#8,#8,#8); 231 | Write(J:4); 232 | Case MaxColors of 256:begin 233 | BlockRead(RawFile,RawLine,MyWidth); 234 | BlockWrite(XgfFile,RawLine,MyWidth); 235 | end; 236 | 16:begin 237 | BlockRead(RawFile,RawLine,MyWidth); 238 | Nb:=StackLine16(MyWidth,RawLine,FormatedLine); 239 | BlockWrite(XgfFile,FormatedLine,Nb); 240 | end; 241 | 4:begin 242 | BlockRead(RawFile,RawLine,MyWidth); 243 | Nb:=PackLine4(MyWidth,RawLine,FormatedLine); 244 | BlockWrite(XgfFile,FormatedLine,Nb); 245 | end; 246 | 2:begin 247 | BlockRead(RawFile,RawLine,MyWidth); 248 | Nb:=StackLine2(MyWidth,RawLine,FormatedLine); 249 | BlockWrite(XgfFile,FormatedLine,Nb); 250 | end; 251 | 252 | end; 253 | Error:=IOResult; 254 | If Error<>0 then 255 | begin 256 | RawToXgf:=Error; 257 | Close(RawFile); 258 | Close(XgfFile); 259 | Exit; 260 | End; 261 | 262 | end; 263 | WriteLn; 264 | 265 | Case CompLan of TPLan,TCLan: BlockWrite(XgfFile,Dummy,2); 266 | GWLan,QBLan,PBLan: 267 | If ShouldPad(MyWidth,MyHeight,MaxColors) then 268 | begin 269 | BlockWrite(XgfFile,Dummy,1); 270 | end; 271 | End; 272 | 273 | Close(RawFile); 274 | Close(XgfFile); 275 | end; 276 | 277 | begin 278 | end. 279 | -------------------------------------------------------------------------------- /RP/RKEY.PAS: -------------------------------------------------------------------------------- 1 | Unit rKey; 2 | Interface 3 | Type 4 | keyRec = Record 5 | UserName : String[25]; 6 | Address : String[25]; 7 | City : String[25]; 8 | State : String[25]; 9 | Country : String[25]; 10 | Zip : String[25]; 11 | Phone : String[25]; 12 | UserNum : String[4]; 13 | C1 : LongInt; 14 | C2 : LongInt; 15 | C3 : LongInt; 16 | C4 : LongInt; 17 | C5 : LongInt; 18 | C6 : LongInt; 19 | C7 : LongInt; 20 | C8 : LongInt; 21 | FC : LongInt; 22 | Extra : String[10]; 23 | End; 24 | 25 | Procedure CreateKey(Var zKey : KeyRec); 26 | Procedure ReadKey(Var zKey : KeyRec;KeyFileName : String); 27 | Procedure WriteKey(Var zKey : KeyRec;KeyFileName : String); 28 | Function ValidKey(zKey : KeyRec) : Boolean; 29 | 30 | Implementation 31 | uses dos; 32 | 33 | Procedure CreateKey(Var zKey : KeyRec); 34 | Var 35 | i : Word; 36 | begin 37 | Write('Enter User Name: '); 38 | ReadLn(zKey.UserName); 39 | Write('Enter Adress: '); 40 | ReadLn(zKey.Address); 41 | Write('Enter City: '); 42 | ReadLn(zKey.City); 43 | Write('Enter State: '); 44 | ReadLn(zKey.State); 45 | Write('Enter Country: '); 46 | ReadLn(zKey.Country); 47 | Write('Enter Zip: '); 48 | ReadLn(zKey.Zip); 49 | Write('Enter Phone: '); 50 | ReadLn(zKey.Phone); 51 | 52 | Write('User Number: '); 53 | ReadLn(zKey.UserNum); 54 | 55 | zKey.C1:=2465; 56 | 57 | For i:=0 to 25 do 58 | begin 59 | zKey.C1:=zKey.C1+((((ORD(zKey.UserName[i])*43257)+69387)*3478)+34302); 60 | end; 61 | WriteLn(zKey.C1); 62 | 63 | zKey.C2:=12236; 64 | For i:=0 to 25 do 65 | begin 66 | zKey.C2:=zKey.C2+((((ORD(zKey.Address[i])*83952)+99307)*3546)+41322); 67 | end; 68 | WriteLn(zKey.C2); 69 | 70 | zKey.C3:=24465; 71 | For i:=0 to 25 do 72 | begin 73 | zKey.C3:=zKey.C3+((((ORD(zKey.City[i])*83257)+28387)*1428)+14301); 74 | end; 75 | WriteLn(zKey.C3); 76 | 77 | zKey.C4:=2465; 78 | For i:=0 to 25 do 79 | begin 80 | zKey.C4:=zKey.C4+((((ORD(zKey.State[i])*23437)+99457)*433)+74312); 81 | end; 82 | WriteLn(zKey.C4); 83 | 84 | zKey.C5:=32465; 85 | For i:=0 to 25 do 86 | begin 87 | zKey.C5:=zKey.C5+((((ORD(zKey.Zip[i])*83467)+48367)*21488)+4312); 88 | end; 89 | WriteLn(zKey.C5); 90 | 91 | zKey.C6:=23465; 92 | For i:=0 to 25 do 93 | begin 94 | zKey.C6:=zKey.C6+((((ORD(zKey.Phone[i])*267)+92979)*4183)+33121); 95 | end; 96 | WriteLn(zKey.C6); 97 | 98 | zKey.C7:=23; 99 | For i:=0 to 4 do 100 | begin 101 | zKey.C7:=zKey.C7+((((ORD(zKey.UserNum[i])*7)+379)*43)+321); 102 | end; 103 | WriteLn(zKey.C7); 104 | 105 | zKey.C8:=2265; 106 | For i:=0 to 25 do 107 | begin 108 | zKey.C8:=zKey.C8+((((ORD(zKey.Country[i])*23447)+99497)*433)+74312); 109 | end; 110 | WriteLn(zKey.C8); 111 | 112 | end; 113 | 114 | Procedure WriteKey(Var zKey : KeyRec;KeyFileName : String); 115 | Var 116 | F : File; 117 | tempBuf : Array[1..256] of Byte; 118 | i : WOrd; 119 | Error : Word; 120 | begin 121 | Move(zKey,tempBuf,SizeOf(KeyRec)); 122 | For i:=1 to 256 do 123 | begin 124 | tempBuf[i]:=256-tempBuf[i]; 125 | end; 126 | {$I-} 127 | Assign(F,KeyFileName); 128 | Rewrite(F,1); 129 | BlockWrite(F,tempBuf,256); 130 | Close(F); 131 | Error:=IORESULT; 132 | {$I+} 133 | End; 134 | 135 | Procedure ReadKey(Var zKey : KeyRec;KeyFileName : String); 136 | Var 137 | F : File; 138 | tempBuf : Array[1..256] of Byte; 139 | i : Word; 140 | Error : Word; 141 | begin 142 | {$I-} 143 | Assign(F,KeyFileName); 144 | Reset(F,1); 145 | BlockRead(F,tempbuf,256); 146 | Close(F); 147 | Error:=IORESULT; 148 | {$I+} 149 | For i:=1 to 256 do 150 | begin 151 | tempBuf[i]:=256-tempBuf[i]; 152 | end; 153 | Move(tempBuf,zKey,SizeOf(KeyRec)); 154 | End; 155 | 156 | Function ValidKey(zKey : KeyRec) : Boolean; 157 | Var 158 | C1,C2,C3, 159 | C4,C5,C6, 160 | C7,C8 : LongInt; 161 | i : Word; 162 | begin 163 | ValidKey:=False; 164 | 165 | C1:=2465; 166 | For i:=0 to 25 do 167 | begin 168 | C1:=C1+((((ORD(zKey.UserName[i])*43257)+69387)*3478)+34302); 169 | end; 170 | 171 | C2:=12236; 172 | For i:=0 to 25 do 173 | begin 174 | C2:=C2+((((ORD(zKey.Address[i])*83952)+99307)*3546)+41322); 175 | end; 176 | 177 | C3:=24465; 178 | For i:=0 to 25 do 179 | begin 180 | C3:=C3+((((ORD(zKey.City[i])*83257)+28387)*1428)+14301); 181 | end; 182 | 183 | C4:=2465; 184 | For i:=0 to 25 do 185 | begin 186 | C4:=C4+((((ORD(zKey.State[i])*23437)+99457)*433)+74312); 187 | end; 188 | 189 | C5:=32465; 190 | For i:=0 to 25 do 191 | begin 192 | C5:=C5+((((ORD(zKey.Zip[i])*83467)+48367)*21488)+4312); 193 | end; 194 | 195 | C6:=23465; 196 | For i:=0 to 25 do 197 | begin 198 | C6:=C6+((((ORD(zKey.Phone[i])*267)+92979)*4183)+33121); 199 | end; 200 | 201 | C7:=23; 202 | For i:=0 to 4 do 203 | begin 204 | C7:=C7+((((ORD(zKey.UserNum[i])*7)+379)*43)+321); 205 | end; 206 | 207 | C8:=2265; 208 | For i:=0 to 25 do 209 | begin 210 | C8:=C8+((((ORD(zKey.Country[i])*23447)+99497)*433)+74312); 211 | end; 212 | 213 | If (zKey.C1 = C1) AND (zKey.C2 = C2) AND (zKey.C3 = C3) AND (zKey.C4 = C4) 214 | AND (zKey.C5 = C5) AND (zKey.C6 = C6) AND (zKey.C7 = C7) AND (zKey.C8 = C8) then 215 | begin 216 | ValidKey:=True; 217 | exit; 218 | end; 219 | ValidKey:=False; 220 | End; 221 | 222 | begin 223 | end. -------------------------------------------------------------------------------- /RP/VARS.PAS: -------------------------------------------------------------------------------- 1 | Unit Vars; 2 | 3 | Interface 4 | uses RKey,DOS; 5 | const 6 | ProgramName = 'RastPort v2.1'; 7 | Copyright = '(c) Copyright 1993-2022 By RetroNick. All Rights Reserved.'; 8 | GitHub1 = 'Get source and latest version from github:'; 9 | GitHub2 = 'https://github.com/RetroNick2020'; 10 | 11 | 12 | Var 13 | RPKey : KeyRec; 14 | CPath : String; 15 | Implementation 16 | 17 | Procedure GetPath; 18 | var 19 | n : nameStr; 20 | d : dirStr; 21 | e : extStr; 22 | BEGIN 23 | fsplit(ParamStr(0),d,n,e); 24 | Cpath:=d; 25 | end; 26 | 27 | begin 28 | GetPath; 29 | ReadKey(RPKey,Cpath+'\RM.KEY'); 30 | end. 31 | -------------------------------------------------------------------------------- /RP/WXGF.PAS: -------------------------------------------------------------------------------- 1 | Unit wXgf; 2 | Interface 3 | uses xgraph,graph; 4 | 5 | Function WriteXgf(x,y,x2,y2,LanType :Word;Filename : String) : Word; 6 | 7 | 8 | Implementation 9 | Function WriteXgf(x,y,x2,y2,LanType :Word;Filename : String) : Word; 10 | Type 11 | ImgRec = Array[1..$FFFF] of Byte; 12 | 13 | Var 14 | myWidth,myHeight : Word; 15 | F : File; 16 | Error : Word; 17 | BytesPerLine : Word; 18 | size : LongInt; 19 | ImgBuf : ^ImgRec; 20 | i,j : Word; 21 | BitPlane2,bitPlane3,BitPlane4 : Word; 22 | temp : byte; 23 | Uline : array[0..2047] of byte; 24 | begin 25 | Error:=0; 26 | Size:=xgraph.imagesize(x,0,x2,0); 27 | BytesPerLine:=Size-6; 28 | 29 | myWidth:=x2-x+1; 30 | myHeight:=y2-y+1; 31 | 32 | 33 | If (GetMaxColor=15) and (lantype=2) then 34 | begin 35 | BitPlane2:=(BytesPerLine SHR 2); 36 | BitPlane3:=(BytesPerLine SHR 1); 37 | BitPlane4:=(BytesPerLine SHR 2) * 3; 38 | end; 39 | 40 | 41 | If (LanType=1) then 42 | begin 43 | Dec(mywidth,1); 44 | Dec(myheight,1); 45 | end 46 | else 47 | begin 48 | If GetMaxColor=255 then 49 | begin 50 | myWidth:=mywidth*8; 51 | end; 52 | end; 53 | 54 | {$I-} 55 | Assign(F,FileName); 56 | Rewrite(F,1); 57 | Error:=IOResult; 58 | If Error <> 0 then 59 | begin 60 | WriteXgf:=Error; 61 | exit; 62 | end; 63 | BlockWrite(F,myWidth,2); 64 | BlockWrite(F,myHeight,2); 65 | GetMem(imgBuf,size); 66 | For i:=y to y2 do 67 | begin 68 | GetImage(x,i,x2,i,ImgBuf^); 69 | Move(ImgBuf^[5],ULine[0],BytesPerLine); 70 | 71 | if (LanType=2) AND (GetMaxColor=15) then 72 | begin 73 | For j:=0 to BitPlane2-1 do 74 | begin 75 | Temp:=Uline[j]; 76 | Uline[j]:=Uline[j+BitPlane4]; 77 | Uline[j+BitPlane4]:=Temp; 78 | Temp:=Uline[j+BitPlane2]; 79 | Uline[j+BitPlane2]:=Uline[j+BitPlane3]; 80 | Uline[j+BitPlane3]:=Temp; 81 | end; 82 | end; 83 | BlockWrite(F,uline,BytesPerLine); 84 | Error:=IOResult; 85 | If Error <> 0 then 86 | begin 87 | WriteXgf:=Error; 88 | FreeMem(ImgBuf,size); 89 | exit; 90 | end; 91 | end; 92 | Close(F); 93 | Error:=IOResult; 94 | {$I+} 95 | If Error <> 0 then 96 | begin 97 | WriteXgf:=Error; 98 | FreeMem(ImgBuf,size); 99 | exit; 100 | end; 101 | WriteXgf:=Error; 102 | end; 103 | 104 | 105 | begin 106 | end. --------------------------------------------------------------------------------