## bitmap-io-old.pkg
# Compiled by:
# src/lib/x-kit/draw/xkit-draw.sublib# This module provides code to read and write depth-1 images
# stored in X11 bitmap file format (see XReadBitmapFile (3X).
# It does not use any threadkit features, and thus can be compiled
# as part of a sequential SML program.
stipulate
package fil = file__premicrothread; # file__premicrothread is from src/lib/std/src/posix/file--premicrothread.pkg package xc = xclient; # xclient is from src/lib/x-kit/xclient/xclient.pkg package g2d = geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg package ss = substring; # substring is from src/lib/std/substring.pkg package w8v = vector_of_one_byte_unts; # vector_of_one_byte_unts is from src/lib/std/src/vector-of-one-byte-unts.pkgherein
package bitmap_io_old
: (weak) Bitmap_Io_Old # Bitmap_Io_Old is from src/lib/x-kit/draw/bitmap-io-old.api {
exception BITMAP_FILE_INVALID;
stipulate
fun scan f s
=
the (f s)
except
_ = [];
fun rev_sscanf format_string input_string
=
scanf::sscanf input_string format_string;
scan_define = scan (scanf::sscanf_by "#define %s %d");
scan_uchar = scan (scanf::sscanf_by "static unsigned char %s = { ");
scan_char = scan (scanf::sscanf_by "static char %s = { ");
herein
Line = SKIP
| DEFINE ((String, Int))
| BEGIN String;
fun scan_string s
=
case (scan_define s)
[sfprintf::STRING s, sfprintf::INT n]
=>
DEFINE (s, n);
_ =>
case (scan_uchar s)
[sfprintf::STRING s]
=>
BEGIN s;
_ =>
case (scan_char s)
[sfprintf::STRING s]
=>
BEGIN s;
_ => SKIP;
esac;
esac;
esac;
end;
is_delim = char::contains " \t\n,}";
# Return TRUE if s1 is a suffix of s2
fun is_suffix (s1, s2)
=
{ n1 = size s1;
n2 = size s2;
(n1 <= n2)
and
ss::is_prefix s1 (ss::make_substring (s2, n2 - n1, n1));
};
fun read_bitmap in_strm
=
{ fun read_line ()
=
case (fil::read_line in_strm)
#
NULL => raise exception BITMAP_FILE_INVALID;
THE s => s;
esac;
input_ss = ss::from_string o read_line;
fun set_wid ( { wide, high, x_hot, y_hot }, w)
=
{ wide=>THE w, high, x_hot, y_hot };
fun set_ht ( { wide, high, x_hot, y_hot }, h)
=
{ wide, high=>THE h, x_hot, y_hot };
fun set_xhot ( { wide, high, x_hot, y_hot }, x)
=
{ wide, high, x_hot=>THE x, y_hot };
fun set_yhot ( { wide, high, x_hot, y_hot }, y)
=
{ wide, high, x_hot, y_hot=>THE y };
fun scan_hdr (arg as { wide, high, x_hot, y_hot } )
=
case (scan_string (read_line ()))
SKIP => scan_hdr arg;
(DEFINE("width", n)) => scan_hdr (set_wid (arg, n));
(DEFINE("height", n)) => scan_hdr (set_ht (arg, n));
(DEFINE("x_hot", n)) => scan_hdr (set_xhot (arg, n));
(DEFINE("y_hot", n)) => scan_hdr (set_yhot (arg, n));
(DEFINE (s, n))
=>
if (is_suffix("_width", s))
scan_hdr (set_wid (arg, n));
elif (is_suffix("_height", s))
scan_hdr (set_ht (arg, n));
elif (is_suffix("_x_hot", s))
scan_hdr (set_xhot (arg, n));
elif (is_suffix("_y_hot", s))
scan_hdr (set_yhot (arg, n));
else
scan_hdr arg;
fi;
(BEGIN s) => arg;
esac;
fun get_next_int ss
=
{ ss' = ss::drop_prefix is_delim ss;
if (ss::is_empty ss')
get_next_int (input_ss());
else
case (int::scan number_string::HEX (ss::getc) ss')
NULL => raise exception BITMAP_FILE_INVALID;
THE v => v;
esac;
fi;
};
my (wide, high, hot)
=
case (scan_hdr { wide=>NULL, high=>NULL, x_hot=>NULL, y_hot=>NULL } )
{ wide => NULL, ... } => raise exception BITMAP_FILE_INVALID;
{ high => NULL, ... } => raise exception BITMAP_FILE_INVALID;
{ wide => THE w, high=>THE h, x_hot=>THE col, y_hot=>THE row }
=>
(w, h, THE ({ col, row } ));
{ wide=>THE w, high=>THE h, ... }
=>
(w, h, NULL);
esac;
bytes_per_line = (wide+7) / 8;
fun get_scan_line ss
=
{ scan_ln = unsafe::vector_of_chars::make bytes_per_line;
fun get (ss, k)
=
if (k < bytes_per_line)
my (byte, ss)
=
get_next_int ss;
unsafe::vector_of_chars::set (scan_ln, k, char::from_int byte);
get (ss, k+1);
else
(byte::string_to_bytes scan_ln, ss);fi;
get (ss, 0);
}; # getScanLine
fun get_data (_, 0, l)
=>
[reverse l];
get_data (ss, n, l)
=>
{ my (scan_ln, ss)
=
get_scan_line ss;
get_data (ss, n - 1, scan_ln ! l);
}; end;
{ image => xc::CS_PIXMAP
{ size => { wide, high },
data => get_data (input_ss(), high, [])
},
hot_spot => hot
};
};
format_define = sfprintf::sprintf' "#define %s%s %d\n";
format_uchar = sfprintf::sprintf' "static unsigned char %sbits[] = {\n";
format_byte = sfprintf::sprintf' "%#04x";
exception NOT_BITMAP;
exception BAD_CS_PIXMAP_DATA = xc::BAD_CS_PIXMAP_DATA;
fun write_bitmap (out_strm, name, { image, hot_spot } )
=
{ name = case name
"" => "";
_ => name + "_";
esac;
fun pr s
=
fil::write (out_strm, s);
fun write_define (s, n)
=
pr (format_define [sfprintf::STRING name, sfprintf::STRING s, sfprintf::INT n]);
my (wide, high, data)
=
case image
#
xc::CS_PIXMAP { size=>{ wide, high }, data => [data] }
=>
(wide, high, data);
_ => raise exception NOT_BITMAP;
esac;
fun pr_data ()
=
{ bytes_per_line = (wide + 7) / 8;
fun next_byte (s, r, i)
=
if (i < bytes_per_line)
( w8v::get (s, i),
(s, r, i+1)
);
else
next_line r;
fi
also
fun next_line []
=>
raise exception BAD_CS_PIXMAP_DATA;
next_line (s ! r)
=>
if (w8v::length s == bytes_per_line)
next_byte (s, r, 0);
else
raise exception BAD_CS_PIXMAP_DATA;
fi;
end;
fun pr_line (0, _, _)
=>
();
pr_line (n, 12, data)
=>
{ pr ",\n";
pr_line (n, 0, data);
};
pr_line (n, k, data)
=>
{ my (byte, data)
=
next_byte data;
if (k == 0 ) pr " ";
else pr ", "; fi;
pr (format_byte [sfprintf::UNT8 byte]);
pr_line (n - 1, k+1, data);
};
end;
if (length data == high)
pr_line (high*bytes_per_line, 0, (w8v::from_list [], data, bytes_per_line));
else raise exception BAD_CS_PIXMAP_DATA; fi;
};
write_define ("height", high);
write_define ("width", wide);
case hot_spot
THE ({ col, row } )
=>
{ write_define ("x_hot", col);
write_define ("y_hot", row);
};
_ => ();
esac;
pr (format_uchar [sfprintf::STRING name]);
pr_data ();
pr "\n };\n";
fil::flush out_strm;
};
}; # package bitmap_io_old
end;