%-----------------------------------------------------------------------------%
% vim: ts=4 sw=4 et tw=0 wm=0 ft=mercury
%
% Test bitmaps by checking the output against a simpler implementation.
:- module bitmap_tester.

:- interface.

:- import_module bitmap.
:- import_module bitmap_simple.
:- import_module bool.

%-----------------------------------------------------------------------------%

:- type mypair(T, U) ---> (fst::T) - (snd::U).
:- type tbitmap == mypair(bitmap, sbitmap).

:- inst tbitmap == bound(bitmap - sbitmap).
:- inst uniq_tbitmap == tbitmap. % XXX should be unique
:- mode tbitmap_di == in(uniq_tbitmap). % XXX should be di
:- mode tbitmap_uo == out(uniq_tbitmap).
:- mode tbitmap_ui == in(uniq_tbitmap).

:- type bitmap_result_error
    --->    some [OtherArgs] one_argument(string, sbitmap, OtherArgs, tbitmap)
    ;       some [OtherArgs] two_arguments(string, sbitmap, sbitmap,
                    OtherArgs, tbitmap)
    ;       some [OtherArgs, Result] query(string, sbitmap, OtherArgs,
                    mypair(Result, Result))
    ;       some [OtherArgs, Result] binary_query(string, sbitmap, sbitmap,
                    OtherArgs, mypair(Result, Result))
    .

:- type bitmap_verify_error
    --->    bitmap_verify_error(bitmap, bitmap_verify_error_type).

:- type bitmap_verify_error_type
    --->    hash
    ;       trailing_bits_not_empty
    ;       to_string(string, string)
    .

%-----------------------------------------------------------------------------%

    % new(N, B) creates a bitmap of size N (indexed 0 .. N-1)
    % setting each bit if B = yes and clearing each bit if B = no.
    % An exception is thrown if N is negative.
    %
:- func new(num_bits, bool) = tbitmap.
:- mode new(in, in) = tbitmap_uo is det.

    % Create a new copy of a bitmap.
    %
:- func copy(tbitmap) = tbitmap.
%:- mode copy(tbitmap_ui) = tbitmap_uo is det.
:- mode copy(in) = tbitmap_uo is det.

    % resize(BM, N, B) resizes bitmap BM to have N bits; if N is
    % smaller than the current number of bits in BM then the excess
    % are discarded.  If N is larger than the current number of bits
    % in BM then the new bits are set if B = yes and cleared if
    % B = no.
    %
:- func resize(tbitmap, num_bits, bool) = tbitmap.
:- mode resize(tbitmap_di, in, in) = tbitmap_uo is det.

%-----------------------------------------------------------------------------%

    % Get or set the given bit.
    % The unsafe versions do not check whether the bit is in range.
    %
:- func bit(bit_index, tbitmap) = bool.
%:- mode bit(in, tbitmap_ui) = out is det.
:- mode bit(in, in) = out is det.

:- func 'bit :='(bit_index, tbitmap, bool) = tbitmap.
:- mode 'bit :='(in, tbitmap_di, in) = tbitmap_uo is det.

%-----------------------------------------------------------------------------%

    % Bitmap ^ bits(OffSet, NumBits) = Word.
    % The low order bits of Word contain the NumBits bits of BM
    % starting at OffSet.
    % NumBits must be less than int.bits_per_int.
    %
:- func bits(bit_index, num_bits, tbitmap) = word.
%:- mode bits(in, in, tbitmap_ui) = out is det.
:- mode bits(in, in, in) = out is det.

:- func 'bits :='(bit_index, num_bits, tbitmap, word) = tbitmap.
:- mode 'bits :='(in, in, tbitmap_di, in) = tbitmap_uo is det.

%-----------------------------------------------------------------------------%

:- func byte(int, tbitmap) = int.
%:- mode byte(in, tbitmap_ui) = out is det.
:- mode byte(in, in) = out is det.

:- func 'byte :='(int, tbitmap, int) = tbitmap.
:- mode 'byte :='(in, tbitmap_di, in) = tbitmap_uo is det.

%-----------------------------------------------------------------------------%

    % Flip the given bit.
    %
:- func flip(tbitmap, bit_index) = tbitmap.
:- mode flip(tbitmap_di, in) = tbitmap_uo is det.

%-----------------------------------------------------------------------------%

    % Set operations; for binary operations the second argument is altered
    % in all cases.  The input bitmaps must have the same size.
    %

:- func complement(tbitmap) = tbitmap.
:- mode complement(tbitmap_di) = tbitmap_uo is det.

:- func union(tbitmap, tbitmap) = tbitmap.
%:- mode union(tbitmap_ui, tbitmap_di) = tbitmap_uo is det.
:- mode union(in, tbitmap_di) = tbitmap_uo is det.

:- func intersect(tbitmap, tbitmap) = tbitmap.
%:- mode intersect(tbitmap_ui, tbitmap_di) = tbitmap_uo is det.
:- mode intersect(in, tbitmap_di) = tbitmap_uo is det.

:- func difference(tbitmap, tbitmap) = tbitmap.
%:- mode difference(tbitmap_ui, tbitmap_di) = tbitmap_uo is det.
:- mode difference(in, tbitmap_di) = tbitmap_uo is det.

:- func xor(tbitmap, tbitmap) = tbitmap.
%:- mode xor(tbitmap_ui, tbitmap_di) = tbitmap_uo is det.
:- mode xor(in, tbitmap_di) = tbitmap_uo is det.

%-----------------------------------------------------------------------------%

    % copy_bits(SrcBM, SrcStartBit, DestBM, DestStartBit, NumBits)
    %
    % Overwrite NumBits bits in DestBM starting at DestStartBit with
    % the NumBits bits starting at SrcStartBit in SrcBM.
    %
:- func copy_bits(tbitmap, bit_index, tbitmap, bit_index, num_bits) = tbitmap.
%:- mode copy_bits(tbitmap_ui, in, tbitmap_di, in, in) = tbitmap_uo is det.
:- mode copy_bits(in, in, tbitmap_di, in, in) = tbitmap_uo is det.

    % copy_bits_in_bitmap(BM, SrcStartBit, DestStartBit, NumBits)
    %
    % Overwrite NumBits bits starting at DestStartBit with the NumBits
    % bits starting at SrcStartBit in the same bitmap.
    %
:- func copy_bits_in_bitmap(tbitmap, bit_index, bit_index, num_bits) = tbitmap.
:- mode copy_bits_in_bitmap(tbitmap_di, in, in, in) = tbitmap_uo is det.

    % copy_bytes(SrcBM, SrcStartByte, DestBM, DestStartByte, NumBytes)
    %
    % Overwrite NumBytes bytes in DestBM starting at DestStartByte with
    % the NumBytes bytes starting at SrcStartByte in SrcBM.
    %
:- func copy_bytes(tbitmap, byte_index, tbitmap, byte_index,
    num_bytes) = tbitmap.
%:- mode copy_bytes(tbitmap_ui, in, tbitmap_di, in, in) = tbitmap_uo is det.
:- mode copy_bytes(in, in, tbitmap_di, in, in) = tbitmap_uo is det.

    % copy_bytes_in_bitmap(BM, SrcStartByte, DestStartByte, NumBytes)
    %
    % Overwrite NumBytes bytes starting at DestStartByte with the NumBytes
    % bytes starting at SrcStartByte in the same bitmap.
    %
:- func copy_bytes_in_bitmap(tbitmap, byte_index, byte_index,
    num_bytes) = tbitmap.
:- mode copy_bytes_in_bitmap(tbitmap_di, in, in, in) = tbitmap_uo is det.

:- func to_byte_string(tbitmap) = string.
%:- mode to_byte_string(tbitmap_ui) = out is det.
:- mode to_byte_string(in) = out is det.

:- func ordering(tbitmap, tbitmap) = comparison_result.

:- func test_unify(tbitmap, tbitmap) = bool.

%-----------------------------------------------------------------------------%
:- implementation.

:- import_module char.
:- import_module deconstruct.
:- import_module enum.
:- import_module exception.
:- import_module int.
:- import_module list.
:- import_module require.
:- import_module string.

%-----------------------------------------------------------------------------%

new(N, B) = new(N, B) - new(N, B).

%-----------------------------------------------------------------------------%

resize(BM, NewSize, InitializerBit) = 
    check("resize", BM, {NewSize, InitializerBit},
        resize(BM ^ fst, NewSize, InitializerBit)
            - resize(BM ^ snd, NewSize, InitializerBit)).

copy(BM) = 
    check("copy", BM, {}, copy(BM ^ fst) - copy(BM ^ snd)).

%-----------------------------------------------------------------------------%

bit(I, BM) =
    check_query("bit", BM, I, BM ^ fst ^ bit(I) - BM ^ snd ^ bit(I)).

'bit :='(I, BM, B) =
    check("bit :=", BM, {I, B},
        (BM ^ fst ^ bit(I) := B)
            ^ snd ^ bit(I) := B).

%-----------------------------------------------------------------------------%

bits(FirstBit, NumBits, BM) =
    check_query("bits", BM, {FirstBit, NumBits},
        BM ^ fst ^ bits(FirstBit, NumBits) -
            BM ^ snd ^ bits(FirstBit, NumBits)).

'bits :='(FirstBit, NumBits, BM, Bits) =
    check("bits :=", BM, {FirstBit, NumBits},
        (BM ^ fst ^ bits(FirstBit, NumBits) := Bits)
            ^ snd ^ bits(FirstBit, NumBits) := Bits).

%-----------------------------------------------------------------------------%

byte(I, BM) =
    check_query("byte", BM, I, BM ^ fst ^ byte(I) - BM ^ snd ^ byte(I)).

'byte :='(I, BM, B) =
    check("byte :=", BM, {I, B},
        (BM ^ fst ^ byte(I) := B)
            ^ snd ^ byte(I) := B).

%-----------------------------------------------------------------------------%

flip(BM, I) =
    check("bits :=", BM, I, flip(BM ^ fst, I) - flip(BM ^ snd, I)).

%-----------------------------------------------------------------------------%

complement(BM) =
    check("complement", BM, {}, complement(BM ^ fst) - complement(BM ^ snd)).

%-----------------------------------------------------------------------------%

union(BMa, BMb) =
    check2("union", BMa, BMb, {},
        union(BMa ^ fst, BMb ^ fst)
            - union(BMa ^ snd, BMb ^ snd)).

%-----------------------------------------------------------------------------%

intersect(BMa, BMb) =
    check2("intersect", BMa, BMb, {},
        intersect(BMa ^ fst, BMb ^ fst)
            - intersect(BMa ^ snd, BMb ^ snd)).

%-----------------------------------------------------------------------------%

difference(BMa, BMb) =
    check2("difference", BMa, BMb, {},
        difference(BMa ^ fst, BMb ^ fst)
            - difference(BMa ^ snd, BMb ^ snd)).

%-----------------------------------------------------------------------------%

xor(BMa, BMb) =
    check2("xor", BMa, BMb, {},
        xor(BMa ^ fst, BMb ^ fst)
            - xor(BMa ^ snd, BMb ^ snd)).

%-----------------------------------------------------------------------------%

copy_bits(SrcBM, SrcStartBit, DestBM, DestStartBit, NumBits) =
    check2("copy_bits", SrcBM, DestBM, {SrcStartBit, DestStartBit, NumBits},
        copy_bits(SrcBM ^ fst, SrcStartBit,
            DestBM ^ fst, DestStartBit, NumBits) - 
        copy_bits(SrcBM ^ snd, SrcStartBit,
            DestBM ^ snd, DestStartBit, NumBits)).

copy_bits_in_bitmap(SrcBM, SrcStartBit, DestStartBit, NumBits) =
    check("copy_bits_in_bitmap", SrcBM, {SrcStartBit, DestStartBit, NumBits},
        copy_bits_in_bitmap(SrcBM ^ fst, SrcStartBit, DestStartBit, NumBits) - 
        copy_bits_in_bitmap(SrcBM ^ snd, SrcStartBit, DestStartBit, NumBits)).

copy_bytes(SrcBM, SrcStartByte, DestBM, DestStartByte, NumBytes) =
    check2("copy_bytes", SrcBM, DestBM,
        {SrcStartByte, DestStartByte, NumBytes},
        copy_bytes(SrcBM ^ fst, SrcStartByte,
            DestBM ^ fst, DestStartByte, NumBytes) - 
        copy_bytes(SrcBM ^ snd, SrcStartByte,
            DestBM ^ snd, DestStartByte, NumBytes)).

copy_bytes_in_bitmap(SrcBM, SrcStartByte, DestStartByte, NumBytes) =
    check("copy_bytes_in_bitmap", SrcBM,
        {SrcStartByte, DestStartByte, NumBytes},
        copy_bytes_in_bitmap(SrcBM ^ fst, SrcStartByte,
            DestStartByte, NumBytes) - 
        copy_bytes_in_bitmap(SrcBM ^ snd, SrcStartByte,
            DestStartByte, NumBytes)).

%-----------------------------------------------------------------------------%

ordering(BM1, BM2) =
    check_query2("ordering", BM1, BM2, {},
        builtin.ordering(BM1 ^ fst, BM2 ^ fst) -
        builtin.ordering(BM1 ^ snd, BM2 ^ snd)).

test_unify(BM1, BM2) =
    check_query2("test_unify", BM1, BM2, {},
        pred_to_bool(unify(BM1 ^ fst, BM2 ^ fst)) -
        pred_to_bool(unify(BM1 ^ snd, BM2 ^ snd))).

%-----------------------------------------------------------------------------%

:- func check(string, tbitmap, OtherArgs, tbitmap) = tbitmap.
%:- mode check(in, tbitmap_ui, in, tbitmap_di) = tbitmap_uo is det.
:- mode check(in, in, in, tbitmap_di) = tbitmap_uo is det.

check(Op, Tester0, OtherArgs, Tester) = Tester :-
    Tester = BM - SBM,
    BMArray = to_sbitmap(BM),
    ( verify(BM), BMArray = SBM ->
        true
    ;
        throw('new one_argument'(Op, Tester0 ^ snd, OtherArgs, Tester))
    ).

:- func check2(string, tbitmap, tbitmap, OtherArgs, tbitmap) = tbitmap.
%:- mode check2(in, tbitmap_ui, tbitmap_ui, in, tbitmap_di) = tbitmap_uo is det.
:- mode check2(in, in, in, in, tbitmap_di) = tbitmap_uo is det.

check2(Op, Tester1, Tester2, OtherArgs, Tester) = Result :-
    Tester = BM - SBM,
    BMArray = to_sbitmap(BM),
    ( verify(BM), SBM = BMArray ->
        Result = Tester
    ;
        throw('new two_arguments'(Op, Tester1 ^ snd, Tester2 ^ snd,
            OtherArgs, Tester))
    ).

:- func check_query(string, tbitmap, OtherArgs, mypair(T, T)) = T.
%:- mode check_query(in, tbitmap_ui, in, in) = out is det.
:- mode check_query(in, in, in, in) = out is det.

check_query(Op, Tester1, OtherArgs, Res) = TheRes :-
    Res = Res1 - Res2,
    ( Res1 = Res2 ->
        TheRes = Res1
    ;
        throw('new query'(Op, Tester1 ^ snd, OtherArgs, Res))
    ).

:- func check_query2(string, tbitmap, tbitmap,
    OtherArgs, mypair(T, T)) = T.
%:- mode check_query2(in, tbitmap_ui, tbitmap_ui, in, in) = out is det.
:- mode check_query2(in, in, in, in, in) = out is det.

check_query2(Op, Tester1, Tester2, OtherArgs, Res) = TheRes :-
    Res = Res1 - Res2,
    ( Res1 = Res2 ->
        TheRes = Res1
    ;
        throw('new binary_query'(Op, Tester1 ^ snd, Tester2 ^ snd,
            OtherArgs, Res))
    ).

:- func to_sbitmap(bitmap) = sbitmap.
%:- mode to_sbitmap(bitmap_ui) = sbitmap_uo.
:- mode to_sbitmap(in) = sbitmap_uo.

to_sbitmap(BM) =
    to_sbitmap_2(0, BM ^ num_bits, BM, new(BM ^ num_bits, no)).

:- func to_sbitmap_2(int, int, bitmap, sbitmap) = sbitmap.
%:- mode to_sbitmap_2(in, in, bitmap_ui, sbitmap_di) = sbitmap_uo.
:- mode to_sbitmap_2(in, in, in, sbitmap_di) = sbitmap_uo.

to_sbitmap_2(Index, NumBits, BM, SBM) =
    ( Index < NumBits ->
        to_sbitmap_2(Index + 1, NumBits, BM,
            SBM ^ bit(Index) := BM ^ bit(Index))
    ;
        SBM
    ).

to_byte_string(BM) = to_byte_string(BM ^ fst).

    % At each step we check that the output bitmap can be converted to
    % and from a string, and that the hash produced by the Mercury code
    % in bitmap.m matches that produced by the C code in mercury_bitmap.h.
    % We also check that any trailing bits in the final byte are empty.
:- pred verify(bitmap).
%:- mode verify(bitmap_ui) is semidet.
:- mode verify(in) is semidet.

verify(BM) :-
    % functor/4 uses MR_bitmap_to_string in runtime/mercury_bitmap.h.
    functor(BM, do_not_allow, Functor, _Arity),
    Str = bitmap.to_string(BM),
    (
        Functor = "\"" ++ Str ++ "\"",
        BM = bitmap.from_string(Str)
    ->
        semidet_succeed
    ;
        throw(bitmap_verify_error(BM, to_string(Functor, Str)))
    ),
    ( bitmap.hash(BM) = foreign_hash(BM) ->
        semidet_succeed
    ;
        throw(bitmap_verify_error(BM, hash))
    ),
    NumBits = BM ^ num_bits,
    BitsInLastByte = NumBits `rem` bitmap.bits_per_byte,
    ( BitsInLastByte = 0 ->
        true
    ; 0 = BM ^ unsafe_bits(NumBits, bitmap.bits_per_byte - BitsInLastByte) ->
        true
    ;
        throw(bitmap_verify_error(BM, trailing_bits_not_empty))
    ).

:- pragma foreign_decl("C", "#include ""mercury_bitmap.h""").

:- func foreign_hash(bitmap) = int.
%:- mode foreign_hash(bitmap_ui) = out is det.
:- mode foreign_hash(in) = out is det.
:- pragma promise_pure(foreign_hash/1).

foreign_hash(BM) = bitmap.hash(BM).

:- pragma foreign_proc("C",
    foreign_hash(BM::in) = (Hash::out),
    [will_not_call_mercury, promise_pure],
    "Hash = MR_hash_bitmap(BM);"
).

