with InteAKD; use InteAKD; -- for Demo
     with TextAKD; use TextAKD; -- for Demo
     with ConsAKD; use ConsAKD; -- for Demo

     package body BitsAKD is
     ----------------------------------------------------------------------
     -- Copyright (C) 1994 David Wallace Croft.  All rights reserved.
     ----------------------------------------------------------------------

     function Bits_Are_Set (
       Byte     : Byte_Type;
       Bit_Mask : Byte_Type )
       return boolean is
     ----------------------------------------------------------------------
     begin
       return "And" ( Bit_Mask, Byte ) = Bit_Mask;
     end Bits_Are_Set;

     function Bits_Are_Set (
       Word     : Word_Type;
       Bit_Mask : Word_Type )
       return boolean is
     ----------------------------------------------------------------------
     begin
       return "And" ( Bit_Mask, Word ) = Bit_Mask;
     end Bits_Are_Set;

     function Clear_Bits (
       Byte     : Byte_Type;
       Bit_Mask : Byte_Type )
       return Byte_Type is
     ----------------------------------------------------------------------
     begin
       return "And" ( Byte, "Not" ( Bit_Mask ) );
     end Clear_Bits;

     function  Clear_Bits
		 ( Word: Word_Type;
		   Bit_Mask: Word_Type
		 ) return Word_Type is
     ---------------------------------------------------------------------------
     begin
       return "And" ( Word, "Not" ( Bit_Mask ) );
     end Clear_Bits;

     procedure Demo is
     ----------------------------------------------------------------------
	Default :          natural :=  1;
	Min     : constant natural :=  0;
	Max     : constant natural :=  26;
	Option  :          natural;
     begin
       loop
	 Put_Line ( Copyright );
	 New_Line;
	 Put_Line ( Description );
	 New_Line;
	 Put ( " 1 = ""And"" ( Byte_Type )" );
	 Put_Line ( "             2 = ""Or""  ( Byte_Type )" );
	 Put ( " 3 = ""XOr"" ( Byte_Type )" );
	 Put_Line ( "             4 = ""Not"" ( Byte_Type )" );
	 Put ( " 5 = ShL   ( Byte_Type )" );
	 Put_Line ( "             6 = ShR   ( Byte_Type )" );
	 Put ( " 7 = ""And"" ( Word_Type )" );
	 Put_Line ( "             8 = ""Or""  ( Word_Type )" );
	 Put ( " 9 = ""XOr"" ( Word_Type )" );
	 Put_Line ( "            10 = ""Not"" ( Word_Type )" );
	 Put ( "11 = ShL   ( Word_Type )" );
	 Put_Line ( "            12 = ShR   ( Word_Type )" );
	 Put ( "13 = ""And"" ( Double_Word_Type )" );
	 Put_Line ( "     14 = ""Or""  ( Double_Word_Type )" );
	 Put ( "15 = ""XOr"" ( Double_Word_Type )" );
	 Put_Line ( "     16 = ""Not"" ( Double_Word_Type )" );
	 Put ( "17 = ShL   ( Double_Word_Type )" );
	 Put_Line ( "     18 = ShR   ( Double_Word_Type )" );
	 Put_Line ( "19 = Bits_Are_Set ( Byte_Type )" );
	 Put_Line ( "20 = Bits_Are_Set ( Word_Type )" );
	 Put_Line ( "21 = Clear_Bits ( Byte_Type )" );
	 Put_Line ( "22 = Clear_Bits ( Word_Type )" );
	 Put_Line ( "23 = Get_Byte" );
	 Put_Line ( "24 = Set_Bits ( Byte_Type )" );
	 Put_Line ( "25 = Set_Bits ( Word_Type )" );
	 Put_Line ( "26 = Set_Byte" );
	 Put_Line ( "27 = Shift_Bits ( Word_Type )" );
	 Put_Line ( "28 = Shift_Bits ( Double_Word_Type )" );
	 New_Line;
	 Option := Ask_Nat ( "Option ", Default, Min, Max );
	 Default := Option + 1;
	 if Default > Max then
	   Default := Min;
	 end if;
	 case Option is
	   when  0 => exit;
	   when  1 => Put_Line ( "And" ( Ask_Byte, Ask_Byte ) );
	   when  2 => Put_Line ( "Or"  ( Ask_Byte, Ask_Byte ) );
	   when  3 => Put_Line ( "XOr" ( Ask_Byte, Ask_Byte ) );
	   when  4 => Put_Line ( "Not" ( Ask_Byte ) );
	   when  5 => Put_Line ( ShL ( Ask_Byte,
	     Num_Bits_Type ( Ask_Byte ( "Num_Bits ", 1, 0, 32 ) ) ) );
	   when  6 => Put_Line ( ShR ( Ask_Byte,
	     Num_Bits_Type ( Ask_Byte ( "Num_Bits ", 1, 0, 32 ) ) ) );
	   when  7 => Put_Line ( "And" ( Ask_Int, Ask_Int ) );
	   when  8 => Put_Line ( "Or"  ( Ask_Int, Ask_Int ) );
	   when  9 => Put_Line ( "XOr" ( Ask_Int, Ask_Int ) );
	   when 10 => Put_Line ( "Not" ( Ask_Int ) );
	   when 11 => Put_Line ( ShL ( Ask_Int,
	     Num_Bits_Type ( Ask_Byte ( "Num_Bits ", 1, 0, 32 ) ) ) );
	   when 12 => Put_Line ( ShR ( Ask_Int,
	     Num_Bits_Type ( Ask_Byte ( "Num_Bits ", 1, 0, 32 ) ) ) );
	   when 13 => Put_Line ( "And" ( Ask_Long, Ask_Long ) );
	   when 14 => Put_Line ( "Or"  ( Ask_Long, Ask_Long ) );
	   when 15 => Put_Line ( "XOr" ( Ask_Long, Ask_Long ) );
	   when 16 => Put_Line ( "Not" ( Ask_Long ) );
	   when 17 => Put_Line ( ShL ( Ask_Long,
	     Num_Bits_Type ( Ask_Byte ( "Num_Bits ", 1, 0, 32 ) ) ) );
	   when 18 => Put_Line ( ShR ( Ask_Long,
	     Num_Bits_Type ( Ask_Byte ( "Num_Bits ", 1, 0, 32 ) ) ) );
	   when 19 => Put_Line ( Bits_Are_Set ( Ask_Byte, Ask_Byte ) );
	   when 20 => Put_Line ( Bits_Are_Set ( Ask_Int, Ask_Int ) );
	   when 21 => Put_Line ( Clear_Bits ( Ask_Byte, Ask_Byte ) );
	   when 22 => Put_Line ( Clear_Bits ( Ask_Int, Ask_Int ) );
	   when 23 =>
	     if Ask_Bool ( "Low byte? " ) then
	       Put_Line ( Get_Byte ( Ask_Int, Low_Byte => true ) );
	     else
	       Put_Line ( Get_Byte ( Ask_Int, Low_Byte => false ) );
	     end if;
	   when 24 => Put_Line ( Set_Bits ( Ask_Byte, Ask_Byte ) );
	   when 25 => Put_Line ( Set_Bits ( Ask_Int, Ask_Int ) );
	   when 26 =>
	     if Ask_Bool ( "Low byte? " ) then
	       Put_Line ( Set_Byte ( Ask_Int, Ask_Byte, true ) );
	     else
	       Put_Line ( Set_Byte ( Ask_Int, Ask_Byte, false ) );
	     end if;
	   when 27 =>
	     if Ask_Bool ( "Left? " ) then
	       Put_Line ( Shift_Bits ( Ask_Int,
		 Num_Bits_Type ( Ask_Byte ( "Num_Bits ", 1, 0, 32 ) ),
		 Left => true ) );
	     else
	       Put_Line ( Shift_Bits ( Ask_Int,
		 Num_Bits_Type ( Ask_Byte ( "Num_Bits ", 1, 0, 32 ) ),
		 Left => false ) );
	     end if;
	   when 28 =>
	     if Ask_Bool ( "Left? " ) then
	       Put_Line ( Shift_Bits ( Ask_Long,
		 Num_Bits_Type ( Ask_Byte ( "Num_Bits ", 1, 0, 32 ) ),
		 Left => true ) );
	     else
	       Put_Line ( Shift_Bits ( Ask_Long,
		 Num_Bits_Type ( Ask_Byte ( "Num_Bits ", 1, 0, 32 ) ),
		 Left => false ) );
	     end if;
	   when others =>
	     Put_Line ( "The demonstration of that option is currently"
		  & " not available." );
	 end case;
	 Pause;
	 New_Line;
       end loop;
     end Demo;

     function Get_Byte (
       Word     : Word_Type;
       Low_Byte : boolean := true )
       return Byte_Type is
     ----------------------------------------------------------------------
       Temp : Word_Type;
     begin
       if Low_Byte then
	 Temp := ShR ( ShL ( Word, 8 ), 8 );
       else
	 Temp := ShR ( Word, 8 );
       end if;
       if Temp > 127 then
	 Temp := 255 - Temp + 1;
	 Temp := -Temp;
       end if;
       return Byte_Type ( Temp );
     end Get_Byte;

     function Set_Bits (
       Byte     : Byte_Type;
       Bit_Mask :  Byte_Type )
       return Byte_Type is
     ---------------------------------------------------------------------------
     begin
       return "Or" ( Byte, Bit_Mask );
     end Set_Bits;

     function Set_Bits (
       Word     : Word_Type;
       Bit_Mask : Word_Type )
       return Word_Type is
     ---------------------------------------------------------------------------
     begin
       return "Or" ( Word, Bit_Mask );
     end Set_Bits;

     function Set_Byte (
       Word     : Word_Type;
       New_Byte : Byte_Type;
       Low_Byte : boolean := true )
       return Word_Type is
     ----------------------------------------------------------------------
       Temp: Word_Type;
     begin
       if Low_Byte then
	 return "Or" ( "And" ( Word, -256 ), Word_Type ( New_Byte ) );
	   -- Note:  -256 = -16#0100# = 16#FF00#
       else
	 Temp := Shift_Bits ( Word_Type ( New_Byte ), 8, true );
	 Temp := "Or" ( Temp, "And" ( Word, 16#00FF#   ) );
	 return Temp;
       end if;
     end Set_Byte;

     function Shift_Bits (
       Word     :  Word_Type;
       Num_Bits :  Num_Bits_Type := 1;
       Left     :  boolean       := true )
       return Word_Type is
     ---------------------------------------------------------------------------
     begin
       if Left then
	 return Word_Type (
	   ( ShL ( Double_Word_Type ( Word ), Num_Bits ) )
	     mod Double_Word_Type ( Word_Type'last ) );
       else
	 return ShR ( Word, Num_Bits );
       end if;
     end Shift_Bits;

     function Shift_Bits (
       Double_Word : Double_Word_Type;
       Num_Bits    : Num_Bits_Type := 1;
       Left        : boolean       := true )
       return Double_Word_Type is
     ---------------------------------------------------------------------------
     -- Fixes problem Bit_Ops.ShR has with negative Double_Word_Type.
     -- Shifting left not thoroughly considered.
     -- I cannot remember why I "mod" when shifting left.
     ----------------------------------------------------------------------
       Temp : Double_Word_Type := Double_Word;
     begin
       if Left then
	 Temp := Double_Word_Type (
	   ShL ( Double_Word, Num_Bits ) ) mod Double_Word_Type'last;
       else
	 if Double_Word >= 0 then
	   for index in 1..Num_Bits loop
	     Temp := Temp / 2;
	   end loop;
	 else
	   Temp := "And" ( Temp, 16#7FFF_FFFF# );
	   Temp := Temp / 2;
	   Temp := "Or"  ( Temp, 16#4000_0000# );
	   for index in 1..( Num_Bits - 1) loop
	     Temp := Temp / 2;
	   end loop;
	 end if;
       end if;
       return Temp;
     end Shift_Bits;

     ---------------------------------------------------------------------------
     ---------------------------------------------------------------------------
     end BitsAKD;