gcc/ada/libgnat/g-binsea.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                           GNAT.BINARY_SEARCH                             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                        Copyright (C) 2022-2023, AdaCore                  --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 ------------------------------------------------------------------------------
  27
  28 package body GNAT.Binary_Search is
  29
  30    function Index
  31      (First, Last, Start : Index_Type;
  32       Element            : Element_Type) return Index_Type'Base is
  33    begin
  34       if Leftmost then
  35          declare
  36             function Before
  37               (Index : Index_Type; Element : Element_Type) return Boolean
  38             is (Before (Get (Index), Element)) with Inline_Always;
  39
  40             function Find is new Binary_Search.Leftmost
  41               (Index_Type, Element_Type, Before);
  42          begin
  43             return Find (First, Last, Start, Element);
  44          end;
  45
  46       else
  47          declare
  48             function Before
  49               (Element : Element_Type; Index : Index_Type) return Boolean
  50             is (Before (Element, Get (Index))) with Inline_Always;
  51
  52             function Find is new Rightmost (Index_Type, Element_Type, Before);
  53          begin
  54             return Find (First, Last, Start, Element);
  55          end;
  56       end if;
  57    end Index;
  58
  59    --------------
  60    -- Leftmost --
  61    --------------
  62
  63    function Leftmost
  64      (First, Last, Start : Index_Type;
  65       Element            : Element_Type) return Index_Type'Base
  66    is
  67       L : Index_Type := First;
  68       R : Index_Type := Index_Type'Succ (Last);
  69       M : Index_Type := Start;
  70    begin
  71       if First <= Last then
  72          loop
  73             if Before (M, Element) then
  74                L := Index_Type'Succ (M);
  75             else
  76                R := M;
  77             end if;
  78
  79             exit when L >= R;
  80
  81             M := Index_Type'Val
  82               (Index_Type'Pos (L) +
  83                (Index_Type'Pos (R) - Index_Type'Pos (L)) / 2);
  84          end loop;
  85       end if;
  86
  87       return L;
  88    end Leftmost;
  89
  90    ---------------
  91    -- Rightmost --
  92    ---------------
  93
  94    function Rightmost
  95      (First, Last, Start : Index_Type;
  96       Element            : Element_Type) return Index_Type'Base
  97    is
  98       L : Index_Type := First;
  99       R : Index_Type := Index_Type'Succ (Last);
 100       M : Index_Type := Start;
 101    begin
 102       if First > Last then
 103          return Last;
 104       else
 105          loop
 106             if Before (Element, M) then
 107                R := M;
 108             else
 109                L := Index_Type'Succ (M);
 110             end if;
 111
 112             exit when L >= R;
 113
 114             M := Index_Type'Val
 115               (Index_Type'Pos (L) +
 116                (Index_Type'Pos (R) - Index_Type'Pos (L)) / 2);
 117          end loop;
 118       end if;
 119
 120       return Index_Type'Pred (R);
 121    end Rightmost;
 122
 123 end GNAT.Binary_Search;