Category : Miscellaneous Language Source Code
Archive   : SPL.ZIP
Filename : IPICDUMP.SP

 
Output of file : IPICDUMP.SP contained in archive : SPL.ZIP
BEGIN

{ This program dumps a picture file to the screen. It is
in a format created by hardware by Chorus Data Systems
6 Continental Boulevard in Merrimack,New Hampshire. }

INTEGER POINTER, { This variable points into row of video data. }
Picture, { This variable holds the file number of data file. }
Row_length, {Usually 320 or 112 bytes,two pixels per byte. }
SCALE; { Scale factor of data being plotted. }

INTEGER ARRAY Colors(8); { This array holds the real pixel
values in brightness order. }

STRING ROW; { This variable holds a row of pixel intensities. }

PROCEDURE Advance_file_pointer;
BEGIN

{ This procedure reads 256 bytes which places the file
pointer at the beginning of the data for the picture. }

ROW := INPUT$(255,#Picture); { Read 255 characters not used. }
ROW := INPUT$(1,#Picture); {Read one more character. }

END

PROCEDURE Get_row_of_data;
BEGIN

{ This procedure gets a row of data and puts it into the
STRING ROW. }
IF Row_length<=255 THEN ROW := INPUT$(Row_length,#Picture);
ELSE
BEGIN
ROW := INPUT$(255,#Picture)
+ INPUT$(Row_length-255,#Picture);
END

POINTER := 1; { Read the pixels and set pointer to one. }

END

INTEGER Pixel_value; { Result of PROCEDURE Get_pixel_value. }

PROCEDURE Get_pixel_value;
BEGIN

{ This PROCEDURE will extract a 4 bit pixel intensity and
scale it. }

Pixel_value := ASC(MID$(ROW,INT((POINTER-1)/2+1),1));

IF ( POINTER AND 1 )=0 THEN
BEGIN
Pixel_value := INT((Pixel_value AND 15)/SCALE);
RETURN;
END
ELSE
BEGIN
Pixel_value := INT((Pixel_value \ 16)/SCALE);
RETURN;
END

END

PROCEDURE Setscreen;
BEGIN

{ This PROCEDURE sets the screen from the file of data. }

INTEGER X, { Loop variable X }
Y, { Loop variable Y }
PIXEL; { Pixel value to be plotted. }

SCREEN 9; { Set screen 9 High resolution EGA mode 640x350 }

FOR Y := 0 STEP 1 UNTIL 199 DO
BEGIN
Get_row_of_data;
FOR X := 0 STEP 1 UNTIL (Row_length*2.)-1 DO
BEGIN
Get_pixel_value; PIXEL := Pixel_value;
{ Make sure pixel value is between 0 and 7. }
IF PIXEL>7 THEN PIXEL := 7; IF PIXEL<0 THEN PIXEL := 0;
PSET(X,Y),Colors(PIXEL+1); POINTER := POINTER+1;
END
END

END

{ This is the main program. }

STRING Key; { Holds key value. }
STRING Picture_filename; { Picture file name. }
Picture := 1; {Set picture file number. }

{ Set the proper brightness levels. }
Colors(1) := 0; Colors(2) := 1; Colors(3) := 4; Colors(4) := 5;
Colors(5) := 2; Colors(6) := 3; Colors(7) := 6; Colors(8) := 7;

Start:
ONERRGOTO Error_in_row_length;

Get_row_length:INPUT( 'Enter row length in bytes 320,111 or 112:',
Row_length );

IF Row_length<>320 AND Row_length<>112 AND Row_length<>111
THEN GO Get_row_length;

ONERRGOTO Error_in_scale_factor;

Get_scale_factor:INPUT( 'Enter Scale factor 1-16:',SCALE );

IF SCALE<1 OR SCALE>16 THEN GO Get_scale_factor;

ONERRGOTO Error_in_filename;

Get_filename:
LINEIN( 'Enter picture file name:',Picture_filename);
OPEN( 'I',Picture,Picture_filename); { Open the picture file. }

ONERRGOTO Final_error;

Advance_file_pointer; {Point to 257th character. }
HOME; Setscreen; { Set the video from the data file. }
CLOSE(Picture); {Close the picture file. }
Wait_here:Key:=INKEY$; IF Key='' THEN GO Wait_here;
IF Key='D' THEN
BEGIN
DEFSEG:=57344; BSAVE('PICT.G',0,45000);
DEFSEG:=49152; BSAVE('PICT.B',0,45000);

DEFSEG:=53248; BSAVE('PICT.R',0,45000);
GO Start;
END
ELSE GO Start;

Error_in_row_length:
OUTPUT( 'ERROR,Reenter row length' ); OUTPUT(); RESUME Get_row_length;

Error_in_scale_factor:
OUTPUT( 'ERROR,Reenter scale factor' ); OUTPUT(); RESUME Get_scale_factor;

Error_in_filename:
OUTPUT( 'ERROR,Reenter filename' ); OUTPUT(); RESUME Get_filename;

Final_error:OUTPUT(); OUTPUT('Error:' @ ERR @ 'in line:' @ERL);
RESUME Finish;

Finish:
END


  3 Responses to “Category : Miscellaneous Language Source Code
Archive   : SPL.ZIP
Filename : IPICDUMP.SP

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/