procedure FileToScreen (x, y : int, fileName : string)
var version : int
var bufferSize : int
var xSize, ySize : int
var screenWidth, screenHeight, screenColors : int
var screenMode : string (11)
var paletteUsed : int
var fs : int
open : fs, fileName, read
if fs <= 0 then
put "Unable to open file \"", fileName, "\" for reading."
return
end if
read : fs, version
if version not= 4661 then
put "\"", fileName, "\" is not a legal TM2 file!"
close : fs
return
end if
read : fs, bufferSize
read : fs, xSize, ySize
read : fs, screenWidth, screenHeight, screenColors, screenMode
read : fs, paletteUsed
if paletteUsed = 1 then
var numColours : int
var red, green, blue : array 1 .. 256 of int
read : fs, numColours
if maxcolour not= numColours - 1 then
put "The image contains a palette with ", numColours
put "colours, while the current graphics mode supports "
put maxcolour + 1, " colours. You are probably in a"
put "different graphics mode from the one that this"
put "picture was created in."
close : fs
return
end if
for cnt : 1 .. numColours
read : fs, red (cnt), green (cnt), blue (cnt)
end for
setcolourmap (red, green, blue, numColours)
end if
var pic : array 1 .. bufferSize of int
var bytesToRead, bytesRead : int
var currentY : int
currentY := ySize + y
loop
exit when eof (fs)
read : fs, bytesToRead
read : fs, pic : bytesToRead : bytesRead
if bytesToRead not= bytesRead then
put "\"", fileName, "\" ended in the middle of an image. This"
put "probably means the image was damaged."
return
end if
currentY -= pic (1) + 1
drawpic (x, currentY, pic, 0)
end loop
close : fs
end FileToScreen
procedure ScreenToFile (x1, y1, x2, y2 : int, fileName : string)
var version : int
var bufferSize : int := 1000
var xSize, ySize : int
var screenWidth, screenHeight, screenColors : int
var screenMode : string (11)
var paletteUsed : int
var fs : int
open : fs, fileName, write
if fs <= 0 then
put "Unable to creat file \"", fileName, "\"."
return
end if
version := 4661
write : fs, version
write : fs, bufferSize
xSize := abs (x2 - x1) + 1
ySize := abs (y2 - y1) + 1
write : fs, xSize, ySize
screenWidth := maxx + 1
screenHeight := maxy + 1
screenColors := maxcolor + 1
if screenWidth = 320 then
if screenColors = 4 then
screenMode := "cga"
elsif screenColors = 16 then
screenMode := "16"
else
screenMode := "mcga"
end if
elsif screenWidth = 640 then
if screenHeight = 200 then
if screenColors = 2 then
screenMode := "hmono"
else
screenMode := "h16"
end if
elsif screenHeight = 350 then
screenMode := "ega"
elsif screenHeight = 400 then
screenMode := "svga1"
else
if screenColors = 2 then
screenMode := "v2"
elsif screenColors = 16 then
screenMode := "vga"
else
screenMode := "svga"
end if
end if
elsif screenWidth = 800 then
if screenColors = 16 then
screenMode := "svga3"
else
screenMode := "svga4"
end if
else
if screenColors = 16 then
screenMode := "svga5"
else
screenMode := "svga6"
end if
end if
write : fs, screenWidth, screenHeight, screenColors, screenMode
paletteUsed := 0
write : fs, paletteUsed
var pic : array 1 .. bufferSize of int
var bytesToWrite, bytesWritten : int
var currentY : int
var numRowsInChunk : int
const topRow := max (y1, y2)
const bottomRow := min (y1, y2)
numRowsInChunk := (bufferSize - 3) div sizepic (x1, 1, x2, 1)
currentY := topRow + 1
loop
exit when currentY - numRowsInChunk <= bottomRow
currentY -= numRowsInChunk
takepic (x1, currentY, x2, currentY + numRowsInChunk - 1, pic)
bytesToWrite := sizepic (x1, 0, x2, numRowsInChunk - 1) * 4
write : fs, bytesToWrite
write : fs, pic : bytesToWrite
end loop
takepic (x1, bottomRow, x2, currentY - 1, pic)
bytesToWrite := sizepic (x1, bottomRow, x2, currentY - 1) * 4
write : fs, bytesToWrite
write : fs, pic : bytesToWrite
close : fs
end ScreenToFile
|
