433 lines
11 KiB
Text
433 lines
11 KiB
Text
(*------------------------------------------------------------------*)
|
|
|
|
#define ATS_DYNLOADFLAG 0
|
|
#define ATS_PACKNAME "Rosetta_Code.bitmap_read_ppm_task"
|
|
|
|
#include "share/atspre_staload.hats"
|
|
|
|
staload "bitmap_task.sats"
|
|
|
|
(* You need to staload bitmap_task.dats, so the ATS compiler will have
|
|
access to its implementations of templates. But we staload it
|
|
anonymously, so the programmer will not have access. *)
|
|
staload _ = "bitmap_task.dats"
|
|
|
|
staload "bitmap_read_ppm_task.sats"
|
|
|
|
(*------------------------------------------------------------------*)
|
|
|
|
datavtype magic_number_vt =
|
|
| Netpbm_magic_number of int
|
|
| Unknown_magic_number of ()
|
|
|
|
fn {}
|
|
read_magic_number (inpf : FILEref) : magic_number_vt =
|
|
let
|
|
val i = fileref_getc inpf
|
|
in
|
|
if i <> char2int0 'P' then
|
|
Unknown_magic_number ()
|
|
else
|
|
let
|
|
val i = fileref_getc inpf
|
|
in
|
|
if i < char2int0 '1' && char2int0 '7' < i then
|
|
Unknown_magic_number ()
|
|
else
|
|
Netpbm_magic_number (i - char2int0 '0')
|
|
end
|
|
end
|
|
|
|
fn {}
|
|
get_next_char (inpf : FILEref) : int =
|
|
let
|
|
fnx
|
|
get_next () : int =
|
|
let
|
|
val i = fileref_getc inpf
|
|
in
|
|
if i = char2int0 '#' then
|
|
skip_through_newline ()
|
|
else
|
|
i
|
|
end
|
|
and
|
|
skip_through_newline () : int =
|
|
let
|
|
val i = fileref_getc inpf
|
|
in
|
|
if i < 0 then
|
|
i
|
|
else if i = char2int0 '\n' then
|
|
get_next ()
|
|
else
|
|
skip_through_newline ()
|
|
end
|
|
in
|
|
get_next ()
|
|
end
|
|
|
|
(* The only tokens we need to scan for, in P1 through P6, are unsigned
|
|
integers. P7 headers (Portable Arbitrary Map) have a completely
|
|
different arrangement, but we are not handling that. *)
|
|
fn {}
|
|
get_next_integer (inpf : FILEref)
|
|
(* A negative return value means we have reached the end. We do
|
|
not distinguish whitespace characters from anything else that
|
|
is not a digit or '#'. (Really I want to use intmax_t here,
|
|
rather than llint, but there is no intmax_t support in the
|
|
prelude. The ats2-xprelude package has support, but I am
|
|
avoiding the dependency. *)
|
|
: llint =
|
|
let
|
|
fnx
|
|
look_for_digit () : llint =
|
|
let
|
|
val i = get_next_char inpf
|
|
in
|
|
if i < char2int0 '0' || char2int0 '9' < i then
|
|
look_for_digit ()
|
|
else
|
|
read_digits (g0i2i (i - char2int0 '0'))
|
|
end
|
|
and
|
|
read_digits (x : llint) : llint =
|
|
let
|
|
val i = get_next_char inpf
|
|
in
|
|
if i < char2int0 '0' || char2int0 '9' < i then
|
|
(* I cannot find an "ungetc" in prelude/SATS/filebas.sats,
|
|
so I will use the foreign function interface directly. *)
|
|
let
|
|
typedef FILEstar = $extype"FILE *"
|
|
extern castfn FILEref2star : FILEref -<> FILEstar
|
|
in
|
|
ignoret ($extfcall (int, "ungetc", i, FILEref2star inpf));
|
|
x
|
|
end
|
|
else
|
|
let
|
|
val digit : llint = g0i2i (i - char2int0 '0')
|
|
in
|
|
read_digits ((10LL * x) + digit)
|
|
end
|
|
end
|
|
in
|
|
look_for_digit ()
|
|
end
|
|
|
|
fn {}
|
|
read_ppm_header (inpf : FILEref)
|
|
: Option_vt @(ullint, ullint, ullint) =
|
|
let
|
|
val width = get_next_integer inpf
|
|
in
|
|
if width < 0LL then
|
|
None_vt ()
|
|
else
|
|
let
|
|
val height = get_next_integer inpf
|
|
in
|
|
if height < 0LL then
|
|
None_vt ()
|
|
else
|
|
let
|
|
val maxval = get_next_integer inpf
|
|
in
|
|
if maxval < 0LL then
|
|
None_vt ()
|
|
else
|
|
begin
|
|
(* There is supposed to be a whitespace character (or
|
|
comments and whitespace character) after the
|
|
MAXVAL. We will accept anything, whitespace or
|
|
not. *)
|
|
ignoret (fileref_getc inpf);
|
|
|
|
Some_vt @(g0i2u width, g0i2u height, g0i2u maxval)
|
|
end
|
|
end
|
|
end
|
|
end
|
|
|
|
fn {}
|
|
get_next_single_byte (inpf : FILEref) : llint =
|
|
let
|
|
val i = fileref_getc inpf
|
|
in
|
|
if i < 0 then
|
|
~1LL
|
|
else
|
|
g0i2i i
|
|
end
|
|
|
|
fn {}
|
|
get_next_double_byte (inpf : FILEref) : llint =
|
|
let
|
|
val i1 = fileref_getc inpf
|
|
in
|
|
if i1 < 0 then
|
|
~1LL
|
|
else
|
|
let
|
|
val i0 = fileref_getc inpf
|
|
in
|
|
if i0 < 0 then
|
|
~1LL
|
|
else
|
|
let
|
|
val i1 : llint = g0i2i i1
|
|
and i0 : llint = g0i2i i0
|
|
in
|
|
(i1 * 256LL) + i0
|
|
end
|
|
end
|
|
end
|
|
|
|
(*------------------------------------------------------------------*)
|
|
(* Implementation is provided only for rgb24. *)
|
|
|
|
extern castfn ull2sz : {i : int} ullint i -<> size_t i
|
|
extern castfn ull2u : {i : int} ullint i -<> uint i
|
|
extern castfn ull2u8 : ullint -<> uint8
|
|
|
|
extern fn {}
|
|
read_raw_ppm_rgb24 : $d2ctype (pixmap_read_ppm<rgb24>)
|
|
|
|
extern fn {}
|
|
read_plain_ppm_rgb24 : $d2ctype (pixmap_read_ppm<rgb24>)
|
|
|
|
extern fn {}
|
|
read_general_ppm_rgb24 : $d2ctype (pixmap_read_ppm<rgb24>)
|
|
|
|
extern fn {}
|
|
read_general$width () : [i : pos] size_t i
|
|
|
|
extern fn {}
|
|
read_general$height () : [i : pos] size_t i
|
|
|
|
extern fn {}
|
|
read_general$maxval () : [i : pos | i <= 65535] uint i
|
|
|
|
extern fn {}
|
|
read_general$next_value : FILEref -> llint
|
|
|
|
implement
|
|
pixmap_read_ppm<rgb24> inpf =
|
|
case+ read_magic_number inpf of
|
|
| ~ Unknown_magic_number () => None_vt ()
|
|
| ~ Netpbm_magic_number num =>
|
|
begin
|
|
case+ num of
|
|
| 6 => read_raw_ppm_rgb24 inpf
|
|
| 3 => read_plain_ppm_rgb24 inpf
|
|
| _ => None_vt
|
|
end
|
|
|
|
implement {}
|
|
read_raw_ppm_rgb24 inpf =
|
|
case+ read_ppm_header inpf of
|
|
| ~ None_vt () => None_vt ()
|
|
| ~ Some_vt @(width, height, maxval) =>
|
|
let
|
|
val width = g1ofg0 width
|
|
and height = g1ofg0 height
|
|
and maxval = g1ofg0 maxval
|
|
in
|
|
if (width < 1LLU) + (height < 1LLU) +
|
|
(maxval < 1LLU) + (65535LLU < maxval) then
|
|
None_vt ()
|
|
else
|
|
let
|
|
val w : Size_t = ull2sz width
|
|
val h : Size_t = ull2sz height
|
|
val maxval : uInt = ull2u maxval
|
|
in
|
|
if maxval = 255u then
|
|
let
|
|
val @(pfgc | pix) = pixmap_make<rgb24> (w, h)
|
|
val success =
|
|
load<rgb24> (inpf, pix, rgb24_make (255, 0, 0))
|
|
in
|
|
if ~success then
|
|
begin
|
|
free (pfgc | pix);
|
|
None_vt ()
|
|
end
|
|
else
|
|
Some_vt @(pfgc | pix)
|
|
end
|
|
else if maxval < 256u then
|
|
let
|
|
implement read_general$width<> () = w
|
|
implement read_general$height<> () = h
|
|
implement read_general$maxval<> () = maxval
|
|
implement
|
|
read_general$next_value<> inpf =
|
|
get_next_single_byte inpf
|
|
in
|
|
read_general_ppm_rgb24<> inpf
|
|
end
|
|
else
|
|
let
|
|
implement read_general$width<> () = w
|
|
implement read_general$height<> () = h
|
|
implement read_general$maxval<> () = maxval
|
|
implement
|
|
read_general$next_value<> inpf =
|
|
get_next_double_byte inpf
|
|
in
|
|
read_general_ppm_rgb24<> inpf
|
|
end
|
|
end
|
|
end
|
|
|
|
implement {}
|
|
read_plain_ppm_rgb24 inpf =
|
|
case+ read_ppm_header inpf of
|
|
| ~ None_vt () => None_vt ()
|
|
| ~ Some_vt @(width, height, maxval) =>
|
|
let
|
|
val width = g1ofg0 width
|
|
and height = g1ofg0 height
|
|
and maxval = g1ofg0 maxval
|
|
in
|
|
if (width < 1LLU) + (height < 1LLU) +
|
|
(maxval < 1LLU) + (65535LLU < maxval) then
|
|
None_vt ()
|
|
else
|
|
let
|
|
val w : Size_t = ull2sz width
|
|
val h : Size_t = ull2sz height
|
|
val maxval : uInt = ull2u maxval
|
|
implement read_general$width<> () = w
|
|
implement read_general$height<> () = h
|
|
implement read_general$maxval<> () = maxval
|
|
implement
|
|
read_general$next_value<> inpf =
|
|
get_next_integer inpf
|
|
in
|
|
read_general_ppm_rgb24<> inpf
|
|
end
|
|
end
|
|
|
|
implement {}
|
|
read_general_ppm_rgb24 inpf =
|
|
let
|
|
val [w : int] w = read_general$width<> ()
|
|
and [h : int] h = read_general$height<> ()
|
|
and maxval = read_general$maxval<> ()
|
|
|
|
fn
|
|
scale_value (v : ullint) : uint8 =
|
|
if maxval = 255u then
|
|
ull2u8 v
|
|
else
|
|
let
|
|
val maxval : ullint = g0u2u maxval
|
|
val v = 255LLU * v
|
|
val v1 = v / maxval
|
|
and v0 = v mod maxval
|
|
in
|
|
if v0 + v0 < maxval then
|
|
ull2u8 v1
|
|
else if maxval < v0 + v0 then
|
|
ull2u8 (succ v1)
|
|
else if v1 mod 2LLU = 0LLU then
|
|
ull2u8 v1
|
|
else
|
|
ull2u8 (succ v1)
|
|
end
|
|
|
|
(* For easier programming, start with a fully initialized
|
|
pixmap. The routine probably is I/O-bound, anyway. *)
|
|
val @(pfgc | pix) =
|
|
pixmap_make<rgb24> (w, h, rgb24_make (255, 0, 0))
|
|
|
|
macdef between (i, j, v) =
|
|
let
|
|
val v = ,(v)
|
|
in
|
|
(,(i) <= v) * (v <= ,(j))
|
|
end
|
|
|
|
fun
|
|
loop {x, y : nat | x <= w; y <= h}
|
|
.<h - y, w - x>.
|
|
(pix : !pixmap (rgb24, w, h),
|
|
x : size_t x,
|
|
y : size_t y)
|
|
: bool (* success *) =
|
|
if y = h then
|
|
true
|
|
else if x = w then
|
|
loop (pix, i2sz 0, succ y)
|
|
else
|
|
let
|
|
val maxv : llint = g0u2i maxval
|
|
val vr = read_general$next_value<> inpf
|
|
in
|
|
if ~between (0LL, maxv, vr) then
|
|
false
|
|
else
|
|
let
|
|
val vg = read_general$next_value<> inpf
|
|
in
|
|
if ~between (0LL, maxv, vg) then
|
|
false
|
|
else
|
|
let
|
|
val vb = read_general$next_value<> inpf
|
|
in
|
|
if ~between (0LL, maxv, vb) then
|
|
false
|
|
else
|
|
let
|
|
val r = scale_value (g0i2u vr)
|
|
and g = scale_value (g0i2u vg)
|
|
and b = scale_value (g0i2u vb)
|
|
in
|
|
pix[x, y] := rgb24_make @(r, g, b);
|
|
loop (pix, succ x, y)
|
|
end
|
|
end
|
|
end
|
|
end
|
|
|
|
val success = loop (pix, i2sz 0, i2sz 0)
|
|
in
|
|
if ~success then
|
|
begin
|
|
free (pfgc | pix);
|
|
None_vt ()
|
|
end
|
|
else
|
|
Some_vt @(pfgc | pix)
|
|
end
|
|
|
|
(*------------------------------------------------------------------*)
|
|
|
|
#ifdef BITMAP_READ_PPM_TASK_TEST #then
|
|
|
|
staload "bitmap_write_ppm_task.sats"
|
|
staload _ = "bitmap_write_ppm_task.dats"
|
|
|
|
(* The test program converts a PPM at standard input to a raw PPM with
|
|
MAXVAL 255. *)
|
|
implement
|
|
main0 () =
|
|
let
|
|
val pix_opt = pixmap_read_ppm<rgb24> stdin_ref
|
|
in
|
|
case+ pix_opt of
|
|
| ~ None_vt () => ()
|
|
| ~ Some_vt @(pfgc | pix) =>
|
|
begin
|
|
ignoret (pixmap_write_ppm (stdout_ref, pix));
|
|
free (pfgc | pix)
|
|
end
|
|
end
|
|
|
|
#endif
|
|
|
|
(*------------------------------------------------------------------*)
|