From 2b8b55de4a18757e8d6769e458c84f7c1df1e261 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Mon, 13 Feb 2017 18:27:13 +1100 Subject: Swapped out crypto package for something smaller, revised other code and readme/notes slightly --- src/bundles-containers.adb | 19 +- src/crypto-asymmetric-prime_tables.ads | 193 --- src/crypto-asymmetric.ads | 32 - src/crypto-types-big_numbers-binfield_utils.adb | 319 ----- src/crypto-types-big_numbers-mod_utils.adb | 741 ----------- src/crypto-types-big_numbers-utils.adb | 704 ----------- src/crypto-types-big_numbers.adb | 921 -------------- src/crypto-types-big_numbers.ads | 399 ------ src/crypto-types-random.adb | 72 -- src/crypto-types-random.ads | 41 - src/crypto-types-random_source-file.adb | 144 --- src/crypto-types-random_source-file.ads | 50 - src/crypto-types-random_source.adb | 55 - src/crypto-types-random_source.ads | 27 - src/crypto-types.adb | 944 -------------- src/crypto-types.ads | 357 ------ src/crypto.ads | 25 - src/multi_precision_integers-check.adb | 141 +++ src/multi_precision_integers-check.ads | 12 + src/multi_precision_integers-io.adb | 186 +++ src/multi_precision_integers-io.ads | 63 + src/multi_precision_integers.adb | 1500 +++++++++++++++++++++++ src/multi_precision_integers.ads | 236 ++++ src/rationals.adb | 85 +- src/rationals.ads | 13 +- src/stv.adb | 4 +- 26 files changed, 2197 insertions(+), 5086 deletions(-) delete mode 100644 src/crypto-asymmetric-prime_tables.ads delete mode 100644 src/crypto-asymmetric.ads delete mode 100644 src/crypto-types-big_numbers-binfield_utils.adb delete mode 100644 src/crypto-types-big_numbers-mod_utils.adb delete mode 100644 src/crypto-types-big_numbers-utils.adb delete mode 100644 src/crypto-types-big_numbers.adb delete mode 100644 src/crypto-types-big_numbers.ads delete mode 100644 src/crypto-types-random.adb delete mode 100644 src/crypto-types-random.ads delete mode 100644 src/crypto-types-random_source-file.adb delete mode 100644 src/crypto-types-random_source-file.ads delete mode 100644 src/crypto-types-random_source.adb delete mode 100644 src/crypto-types-random_source.ads delete mode 100644 src/crypto-types.adb delete mode 100644 src/crypto-types.ads delete mode 100644 src/crypto.ads create mode 100644 src/multi_precision_integers-check.adb create mode 100644 src/multi_precision_integers-check.ads create mode 100644 src/multi_precision_integers-io.adb create mode 100644 src/multi_precision_integers-io.ads create mode 100644 src/multi_precision_integers.adb create mode 100644 src/multi_precision_integers.ads (limited to 'src') diff --git a/src/bundles-containers.adb b/src/bundles-containers.adb index 8ba0d30..029d7c0 100644 --- a/src/bundles-containers.adb +++ b/src/bundles-containers.adb @@ -20,24 +20,15 @@ package body Bundles.Containers is use type Bundle_Maps.Cursor; use type Bundle_Vectors.Vector; - procedure Update_Bundle - (B : in out Bundle) is - begin - Add (B, Item); - end Update_Bundle; - - procedure Update_Vector - (C : in Candidates.CandidateID; - V : in out Bundle_Vectors.Vector) is - begin - V.Update_Element (V.First_Index, Update_Bundle'Access); - end Update_Vector; - Place : Candidates.CandidateID := Item (Given_Prefs.Preference_Range'First); Current_Cursor : Bundle_Maps.Cursor := BMap.Find (Place); begin if Current_Cursor /= Bundle_Maps.No_Element then - BMap.Update_Element (Current_Cursor, Update_Vector'Access); + declare + Vec_Ref : Bundle_Maps.Reference_Type := BMap.Reference (Current_Cursor); + begin + Add (Vec_Ref.Reference (Vec_Ref.First_Index), Item); + end; else declare New_Bundle : Bundle := Empty_Bundle; diff --git a/src/crypto-asymmetric-prime_tables.ads b/src/crypto-asymmetric-prime_tables.ads deleted file mode 100644 index 66eba8e..0000000 --- a/src/crypto-asymmetric-prime_tables.ads +++ /dev/null @@ -1,193 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - - -with Crypto.Types; -use Crypto.Types; - -package Crypto.Asymmetric.Prime_Tables is - - One_Digit_Primes : constant array(Natural range <>) of Natural := - (2, 3, 5, 7); - - Two_Digit_Primes : constant array(Natural range <>) of Natural := - (11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, - 53, 59, 61, 67, 71, 73, 79, 83, 89, 97); - - Three_Digit_Primes : constant array(Natural range <>) of Natural := - ( 101, 103, 107, 109, 113, 127, 131, 137, 139, 149, 151, 157, 163, - 167, 173, 179, 181, 191, 193, 197, 199, 211, 223, 227, 229, 233, - 239, 241, 251, 257, 263, 269, 271, 277, 281, 283, 293, 307, 311, - 313, 317, 331, 337, 347, 349, 353, 359, 367, 373, 379, 383, 389, - 397, 401, 409, 419, 421, 431, 433, 439, 443, 449, 457, 461, 463, - 467, 479, 487, 491, 499, 503, 509, 521, 523, 541, 547, 557, 563, - 569, 571, 577, 587, 593, 599, 601, 607, 613, 617, 619, 631, 641, - 643, 647, 653, 659, 661, 673, 677, 683, 691, 701, 709, 719, 727, - 733, 739, 743, 751, 757, 761, 769, 773, 787, 797, 809, 811, 821, - 823, 827, 829, 839, 853, 857, 859, 863, 877, 881, 883, 887, 907, - 911, 919, 929, 937, 941, 947, 953, 967, 971, 977, 983, 991, 997); - - - Four_Digit_Primes : constant array(Natural range <>) of Natural := - ( 1009, 1013, 1019, 1021, 1031, 1033, 1039, 1049, 1051, 1061, 1063, - 1069, 1087, 1091, 1093, 1097, 1103, 1109, 1117, 1123, 1129, 1151, - 1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213, 1217, 1223, 1229, - 1231, 1237, 1249, 1259, 1277, 1279, 1283, 1289, 1291, 1297, 1301, - 1303, 1307, 1319, 1321, 1327, 1361, 1367, 1373, 1381, 1399, 1409, - 1423, 1427, 1429, 1433, 1439, 1447, 1451, 1453, 1459, 1471, 1481, - 1483, 1487, 1489, 1493, 1499, 1511, 1523, 1531, 1543, 1549, 1553, - 1559, 1567, 1571, 1579, 1583, 1597, 1601, 1607, 1609, 1613, 1619, - 1621, 1627, 1637, 1657, 1663, 1667, 1669, 1693, 1697, 1699, 1709, - 1721, 1723, 1733, 1741, 1747, 1753, 1759, 1777, 1783, 1787, 1789, - 1801, 1811, 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879, - 1889, 1901, 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987, - 1993, 1997, 1999, 2003, 2011, 2017, 2027, 2029, 2039, 2053, 2063, - 2069, 2081, 2083, 2087, 2089, 2099, 2111, 2113, 2129, 2131, 2137, - 2141, 2143, 2153, 2161, 2179, 2203, 2207, 2213, 2221, 2237, 2239, - 2243, 2251, 2267, 2269, 2273, 2281, 2287, 2293, 2297, 2309, 2311, - 2333, 2339, 2341, 2347, 2351, 2357, 2371, 2377, 2381, 2383, 2389, - 2393, 2399, 2411, 2417, 2423, 2437, 2441, 2447, 2459, 2467, 2473, - 2477, 2503, 2521, 2531, 2539, 2543, 2549, 2551, 2557, 2579, 2591, - 2593, 2609, 2617, 2621, 2633, 2647, 2657, 2659, 2663, 2671, 2677, - 2683, 2687, 2689, 2693, 2699, 2707, 2711, 2713, 2719, 2729, 2731, - 2741, 2749, 2753, 2767, 2777, 2789, 2791, 2797, 2801, 2803, 2819, - 2833, 2837, 2843, 2851, 2857, 2861, 2879, 2887, 2897, 2903, 2909, - 2917, 2927, 2939, 2953, 2957, 2963, 2969, 2971, 2999, 3001, 3011, - 3019, 3023, 3037, 3041, 3049, 3061, 3067, 3079, 3083, 3089, 3109, - 3119, 3121, 3137, 3163, 3167, 3169, 3181, 3187, 3191, 3203, 3209, - 3217, 3221, 3229, 3251, 3253, 3257, 3259, 3271, 3299, 3301, 3307, - 3313, 3319, 3323, 3329, 3331, 3343, 3347, 3359, 3361, 3371, 3373, - 3389, 3391, 3407, 3413, 3433, 3449, 3457, 3461, 3463, 3467, 3469, - 3491, 3499, 3511, 3517, 3527, 3529, 3533, 3539, 3541, 3547, 3557, - 3559, 3571, 3581, 3583, 3593, 3607, 3613, 3617, 3623, 3631, 3637, - 3643, 3659, 3671, 3673, 3677, 3691, 3697, 3701, 3709, 3719, 3727, - 3733, 3739, 3761, 3767, 3769, 3779, 3793, 3797, 3803, 3821, 3823, - 3833, 3847, 3851, 3853, 3863, 3877, 3881, 3889, 3907, 3911, 3917, - 3919, 3923, 3929, 3931, 3943, 3947, 3967, 3989, 4001, 4003, 4007, - 4013, 4019, 4021, 4027, 4049, 4051, 4057, 4073, 4079, 4091, 4093, - 4099, 4111, 4127, 4129, 4133, 4139, 4153, 4157, 4159, 4177, 4201, - 4211, 4217, 4219, 4229, 4231, 4241, 4243, 4253, 4259, 4261, 4271, - 4273, 4283, 4289, 4297, 4327, 4337, 4339, 4349, 4357, 4363, 4373, - 4391, 4397, 4409, 4421, 4423, 4441, 4447, 4451, 4457, 4463, 4481, - 4483, 4493, 4507, 4513, 4517, 4519, 4523, 4547, 4549, 4561, 4567, - 4583, 4591, 4597, 4603, 4621, 4637, 4639, 4643, 4649, 4651, 4657, - 4663, 4673, 4679, 4691, 4703, 4721, 4723, 4729, 4733, 4751, 4759, - 4783, 4787, 4789, 4793, 4799, 4801, 4813, 4817, 4831, 4861, 4871, - 4877, 4889, 4903, 4909, 4919, 4931, 4933, 4937, 4943, 4951, 4957, - 4967, 4969, 4973, 4987, 4993, 4999, 5003, 5009, 5011, 5021, 5023, - 5039, 5051, 5059, 5077, 5081, 5087, 5099, 5101, 5107, 5113, 5119, - 5147, 5153, 5167, 5171, 5179, 5189, 5197, 5209, 5227, 5231, 5233, - 5237, 5261, 5273, 5279, 5281, 5297, 5303, 5309, 5323, 5333, 5347, - 5351, 5381, 5387, 5393, 5399, 5407, 5413, 5417, 5419, 5431, 5437, - 5441, 5443, 5449, 5471, 5477, 5479, 5483, 5501, 5503, 5507, 5519, - 5521, 5527, 5531, 5557, 5563, 5569, 5573, 5581, 5591, 5623, 5639, - 5641, 5647, 5651, 5653, 5657, 5659, 5669, 5683, 5689, 5693, 5701, - 5711, 5717, 5737, 5741, 5743, 5749, 5779, 5783, 5791, 5801, 5807, - 5813, 5821, 5827, 5839, 5843, 5849, 5851, 5857, 5861, 5867, 5869, - 5879, 5881, 5897, 5903, 5923, 5927, 5939, 5953, 5981, 5987, 6007, - 6011, 6029, 6037, 6043, 6047, 6053, 6067, 6073, 6079, 6089, 6091, - 6101, 6113, 6121, 6131, 6133, 6143, 6151, 6163, 6173, 6197, 6199, - 6203, 6211, 6217, 6221, 6229, 6247, 6257, 6263, 6269, 6271, 6277, - 6287, 6299, 6301, 6311, 6317, 6323, 6329, 6337, 6343, 6353, 6359, - 6361, 6367, 6373, 6379, 6389, 6397, 6421, 6427, 6449, 6451, 6469, - 6473, 6481, 6491, 6521, 6529, 6547, 6551, 6553, 6563, 6569, 6571, - 6577, 6581, 6599, 6607, 6619, 6637, 6653, 6659, 6661, 6673, 6679, - 6689, 6691, 6701, 6703, 6709, 6719, 6733, 6737, 6761, 6763, 6779, - 6781, 6791, 6793, 6803, 6823, 6827, 6829, 6833, 6841, 6857, 6863, - 6869, 6871, 6883, 6899, 6907, 6911, 6917, 6947, 6949, 6959, 6961, - 6967, 6971, 6977, 6983, 6991, 6997, 7001, 7013, 7019, 7027, 7039, - 7043, 7057, 7069, 7079, 7103, 7109, 7121, 7127, 7129, 7151, 7159, - 7177, 7187, 7193, 7207, 7211, 7213, 7219, 7229, 7237, 7243, 7247, - 7253, 7283, 7297, 7307, 7309, 7321, 7331, 7333, 7349, 7351, 7369, - 7393, 7411, 7417, 7433, 7451, 7457, 7459, 7477, 7481, 7487, 7489, - 7499, 7507, 7517, 7523, 7529, 7537, 7541, 7547, 7549, 7559, 7561, - 7573, 7577, 7583, 7589, 7591, 7603, 7607, 7621, 7639, 7643, 7649, - 7669, 7673, 7681, 7687, 7691, 7699, 7703, 7717, 7723, 7727, 7741, - 7753, 7757, 7759, 7789, 7793, 7817, 7823, 7829, 7841, 7853, 7867, - 7873, 7877, 7879, 7883, 7901, 7907, 7919, 7927, 7933, 7937, 7949, - 7951, 7963, 7993, 8009, 8011, 8017, 8039, 8053, 8059, 8069, 8081, - 8087, 8089, 8093, 8101, 8111, 8117, 8123, 8147, 8161, 8167, 8171, - 8179, 8191, 8209, 8219, 8221, 8231, 8233, 8237, 8243, 8263, 8269, - 8273, 8287, 8291, 8293, 8297, 8311, 8317, 8329, 8353, 8363, 8369, - 8377, 8387, 8389, 8419, 8423, 8429, 8431, 8443, 8447, 8461, 8467, - 8501, 8513, 8521, 8527, 8537, 8539, 8543, 8563, 8573, 8581, 8597, - 8599, 8609, 8623, 8627, 8629, 8641, 8647, 8663, 8669, 8677, 8681, - 8689, 8693, 8699, 8707, 8713, 8719, 8731, 8737, 8741, 8747, 8753, - 8761, 8779, 8783, 8803, 8807, 8819, 8821, 8831, 8837, 8839, 8849, - 8861, 8863, 8867, 8887, 8893, 8923, 8929, 8933, 8941, 8951, 8963, - 8969, 8971, 8999, 9001, 9007, 9011, 9013, 9029, 9041, 9043, 9049, - 9059, 9067, 9091, 9103, 9109, 9127, 9133, 9137, 9151, 9157, 9161, - 9173, 9181, 9187, 9199, 9203, 9209, 9221, 9227, 9239, 9241, 9257, - 9277, 9281, 9283, 9293, 9311, 9319, 9323, 9337, 9341, 9343, 9349, - 9371, 9377, 9391, 9397, 9403, 9413, 9419, 9421, 9431, 9433, 9437, - 9439, 9461, 9463, 9467, 9473, 9479, 9491, 9497, 9511, 9521, 9533, - 9539, 9547, 9551, 9587, 9601, 9613, 9619, 9623, 9629, 9631, 9643, - 9649, 9661, 9677, 9679, 9689, 9697, 9719, 9721, 9733, 9739, 9743, - 9749, 9767, 9769, 9781, 9787, 9791, 9803, 9811, 9817, 9829, 9833, - 9839, 9851, 9857, 9859, 9871, 9883, 9887, 9901, 9907, 9923, 9929, - 9931, 9941, 9949, 9967, 9973); - - - -- binary field squaring tables - - T8 : constant array (0..15) of Byte := - (0, 1, 4, 5, 16, 17, 20, 21, 64, 65, 68, 69, 80, 81, 84, 85); - - T16 : constant array (Byte) of DByte := - ( - 0, 1, 4, 5, 16, 17, 20, 21, - 64, 65, 68, 69, 80, 81, 84, 85, - 256, 257, 260, 261, 272, 273, 276, 277, - 320, 321, 324, 325, 336, 337, 340, 341, - 1024, 1025, 1028, 1029, 1040, 1041, 1044, 1045, - 1088, 1089, 1092, 1093, 1104, 1105, 1108, 1109, - 1280, 1281, 1284, 1285, 1296, 1297, 1300, 1301, - 1344, 1345, 1348, 1349, 1360, 1361, 1364, 1365, - 4096, 4097, 4100, 4101, 4112, 4113, 4116, 4117, - 4160, 4161, 4164, 4165, 4176, 4177, 4180, 4181, - 4352, 4353, 4356, 4357, 4368, 4369, 4372, 4373, - 4416, 4417, 4420, 4421, 4432, 4433, 4436, 4437, - 5120, 5121, 5124, 5125, 5136, 5137, 5140, 5141, - 5184, 5185, 5188, 5189, 5200, 5201, 5204, 5205, - 5376, 5377, 5380, 5381, 5392, 5393, 5396, 5397, - 5440, 5441, 5444, 5445, 5456, 5457, 5460, 5461, - 16384, 16385, 16388, 16389, 16400, 16401, 16404, 16405, - 16448, 16449, 16452, 16453, 16464, 16465, 16468, 16469, - 16640, 16641, 16644, 16645, 16656, 16657, 16660, 16661, - 16704, 16705, 16708, 16709, 16720, 16721, 16724, 16725, - 17408, 17409, 17412, 17413, 17424, 17425, 17428, 17429, - 17472, 17473, 17476, 17477, 17488, 17489, 17492, 17493, - 17664, 17665, 17668, 17669, 17680, 17681, 17684, 17685, - 17728, 17729, 17732, 17733, 17744, 17745, 17748, 17749, - 20480, 20481, 20484, 20485, 20496, 20497, 20500, 20501, - 20544, 20545, 20548, 20549, 20560, 20561, 20564, 20565, - 20736, 20737, 20740, 20741, 20752, 20753, 20756, 20757, - 20800, 20801, 20804, 20805, 20816, 20817, 20820, 20821, - 21504, 21505, 21508, 21509, 21520, 21521, 21524, 21525, - 21568, 21569, 21572, 21573, 21584, 21585, 21588, 21589, - 21760, 21761, 21764, 21765, 21776, 21777, 21780, 21781, - 21824, 21825, 21828, 21829, 21840, 21841, 21844, 21845 - ); - - - - end Crypto.Asymmetric.Prime_Tables; diff --git a/src/crypto-asymmetric.ads b/src/crypto-asymmetric.ads deleted file mode 100644 index 34fbc30..0000000 --- a/src/crypto-asymmetric.ads +++ /dev/null @@ -1,32 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - ---with Crypto; - -package Crypto.Asymmetric is - - Invalid_Public_Key_Error : exception; - Invalid_Private_Key_Error : exception; - Plaintext_Too_Long_Error : exception; - Decrypt_Error : exception; - -end Crypto.Asymmetric; diff --git a/src/crypto-types-big_numbers-binfield_utils.adb b/src/crypto-types-big_numbers-binfield_utils.adb deleted file mode 100644 index 5835b6d..0000000 --- a/src/crypto-types-big_numbers-binfield_utils.adb +++ /dev/null @@ -1,319 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - - --- Most algorithms based on Kankerson, Menezes and Vanstones --- "Guide to Elliptic Curve Cryptograpyh" (ISBN: 0-387-95273-x) - - --- f(z) = 2^m + r(z) --- R is the binary representation of r(z) - -with Crypto.Asymmetric.Prime_Tables; - - -separate(Crypto.Types.Big_Numbers) - -package body Binfield_Utils is - - function B_Mod(Left : D_Big_Unsigned; Right : Big_Unsigned) - return Big_Unsigned; - - function "xor"(Left, Right: D_Big_Unsigned) return D_Big_Unsigned; - - procedure Set_Last_Index(X : in out D_Big_Unsigned); - - --------------------------------------------------------------------------- - - pragma Optimize (Time); - use Crypto.Asymmetric.Prime_Tables; - - -- compute: a(z) + b(z) mod f(z) - function B_Add(Left,Right : Big_Unsigned) return Big_Unsigned is - N : constant Natural := Natural'Max(Left.Last_Index, Right.Last_Index); - C : Big_Unsigned; - begin - for I in 0..N loop - C.Number(I) := Left.Number(i) xor Right.Number(I); - end loop; - - for I in reverse 0..N loop - if C.Number(I) /= 0 then - C.Last_Index :=I; - exit; - end if; - end loop; - - return C; - end B_Add; - - --------------------------------------------------------------------------- - - - -- compute: a(z) - b(z) mod f(z) - -- in binary field is -a = a. so a - b = a + (-b) = a + b - function B_Sub(Left,Right : Big_Unsigned) return Big_Unsigned is - begin - return B_Add(Left,Right); - end B_Sub; - - - --------------------------------------------------------------------------- - - -- compute: a(z)* z mod f(Z) - function B_Mult(A, F : Big_Unsigned) - return Big_Unsigned is - C : Big_Unsigned; - M : constant Positive := Bit_Length(F)-1; - N : Natural:= M/Word'Size; - begin - C := Shift_Left(A,1); - - if C.Last_Index = N then - N:=M mod Word'Size; - - if (Shift_Right(C.Number(C.Last_Index),N)) = 1 then - C := B_Add(C,F); - end if; - end if; - return C; - - end B_Mult; - - --------------------------------------------------------------------------- - - - --Algorithm 2.34: Right to left comb method for polynominal multiplication - -- compute: a(z)*b(z) mod f(Z) - function B_Mult(Left, Right, F : Big_Unsigned) return Big_Unsigned is - C : D_Big_Unsigned; - B : Big_Unsigned := Right; - -- N : constant Natural := Bit_Length(F); - begin - for K in 0..Word'Size-1 loop - for J in 0..Left.Last_Index loop - if (Shift_Right(Left.Number(J),K) and 1) = 1 then - -- add B to C{i} - for I in J..(J+B.Last_Index) loop - C.Number(I) := C.Number(I) xor B.Number(I-J); - end loop; - end if; - end loop; - if K /= Word'Size-1 then - B:=B_Mult(B,F); - end if; - end loop; - - Set_Last_Index(C); - - return B_Mod(C,F); - - end B_Mult; - - --------------------------------------------------------------------------- - - -- Algorithm 2.39: Polynominal squaring (with wordlength W=8) - -- compute a(z)**2 mod f(z) on a 8 bit processor - -- function B_Square8(A, F : Big_Unsigned) return Big_Unsigned is - -- C : D_Big_Unsigned; - -- L : Natural; - -- begin - -- for I in 0..A.Last_Index loop - -- L := 2*I; - -- C.Number(L) := Word(T8(Natural(A.Number(I) and 15))); - -- L:= L+1; - -- C.Number(L) := - -- Word(T8(Natural(Shift_Right(A.Number(I),4) and 15))); - -- end loop; - - -- Set_Last_Index(C); - - -- return B_Mod(C,F); - -- end B_Square8; - - ------------------------------------------------------------------------- - - -- Algorithm 2.39: Polynominal squaring (with word length W=n*8 for n=>0) - -- compute a(z)**2 mod f(z) - function B_Square(A, F : Big_Unsigned) return Big_Unsigned is - K : constant Natural := Word'Size/8; - N : constant Natural := K/2-1; - --M : constant Natural := Bit_Length(F); - L : Natural; - C : D_Big_Unsigned; - begin - for I in 0..A.Last_Index loop - L := 2*I; - for J in reverse 0..N loop - C.Number(L) := Shift_Left(C.Number(L),16) xor - Word(T16(Byte(Shift_Right(A.Number(I),8*J) and 255))); - end loop; - L:= L+1; - for J in reverse K/2..K-1 loop - C.Number(L) := Shift_Left(C.Number(L),16) xor - Word(T16(Byte(Shift_Right(A.Number(I),8*J) and 255))); - end loop; - end loop; - Set_Last_Index(C); - - return B_Mod(C,F); - end B_Square; - --------------------------------------------------------------------------- - - -- It' my own secret "blow and cut" technic. ;-) - -- compute left(z) mod right(z) - function B_Mod(Left, Right : Big_Unsigned) return Big_Unsigned is - A : Natural := Bit_Length(Left); - B : constant Natural := Bit_Length(Right); - Result : Big_Unsigned; - begin - if A < B or B=0 then - Result.Last_Index := Left.Last_Index; - Result.Number(0..Left.Last_Index) := Left.Number(0..Left.Last_Index); - else - while A >= B loop - Result := Shift_Left(Right,A-B) xor Right; - A := Bit_Length(Result); - end loop; - end if; - return Result; - end B_Mod; - - - - -------------------------------------------------------------------------- - - -- Algorithm 2.49: Binary algorithm for inversion in F_{2^m} - -- computes a(z)^{-1} - function B_Inverse(X, F : Big_Unsigned) return Big_Unsigned is - U : Big_Unsigned := X; - V : Big_Unsigned := F; - G1 : Big_Unsigned := Big_Unsigned_One; - G2 : Big_Unsigned; - begin - if X = Big_Unsigned_Zero or F = Big_Unsigned_Zero then - return F; - end if; - - while U /= Big_Unsigned_One and V /= Big_Unsigned_One loop - - while Is_Even(U) loop - U := Shift_Right(U,1); - if Is_Even(G1) then - G1 := Shift_Right(G1,1); - else - G1 := Shift_Right(B_Add(G1,F),1); - end if; - end loop; - - while Is_Even(V) loop - V := Shift_Right(V,1); - if Is_Even(G2) then - G2 := Shift_Right(G2,1); - else - G2 := Shift_Right(B_Add(G2,F),1); - end if; - end loop; - - if Bit_Length(U) > Bit_Length(V) then - U := B_Add(U,V); - G1 := B_Add(G1,G2); - else - V := B_Add(V,U); - G2 := B_Add(G2,G1); - end if; - end loop; - if U = Big_Unsigned_One then - return G1; - else - return G2; - end if; - end B_Inverse; - - -------------------------------------------------------------------------- - - function B_Div(Left, Right, F : Big_Unsigned) return Big_Unsigned is - R : constant Big_Unsigned := B_Inverse(Right, F); - begin - return B_Mult(Left,R,F); - end B_Div; - - -------------------------------------------------------------------------- - -------------------------------------------------------------------------- - - function B_Mod(Left : D_Big_Unsigned; Right : Big_Unsigned) - return Big_Unsigned is - A : Natural := Bit_Length(Left); - B : constant Natural := Bit_Length(Right); - Result : Big_Unsigned; - begin - if A < B or B=0 then - Result.Last_Index := Left.Last_Index; - Result.Number(0..Left.Last_Index) := Left.Number(0..Left.Last_Index); - else - declare - T : D_Big_Unsigned := Left; - Z : D_Big_Unsigned; - begin - Z.Last_Index := Right.Last_Index; - Z.Number(0..Right.Last_Index) := Right.Number(0..Right.Last_Index); - while A >= B loop - T := Shift_Left(Z,A-B) xor T; - A := Bit_Length(T); - end loop; - Result.Last_Index := T.Last_Index; - Result.Number(0..T.Last_Index) := T.Number(0..T.Last_Index); - end; - end if; - return Result; - end B_Mod; - - - -------------------------------------------------------------------------- - - function "xor"(Left, Right: D_Big_Unsigned) return D_Big_Unsigned is - Result : D_Big_Unsigned; - M : constant Natural:= Natural'Max(Left.Last_Index, Right.Last_Index); - begin - for I in 0..M loop - Result.Number(I) := Left.Number(I) xor Right.Number(I); - end loop; - Set_Last_Index(Result); - - return Result; - end "xor"; - - - -------------------------------------------------------------------------- - - procedure Set_Last_Index(X : in out D_Big_Unsigned) is - begin - for I in reverse 0..D_Max_Length loop - if X.Number(I) /= 0 then - X.Last_Index :=I; - exit; - end if; - end loop; - end Set_Last_Index; pragma Inline(Set_Last_Index); - -end Binfield_Utils; diff --git a/src/crypto-types-big_numbers-mod_utils.adb b/src/crypto-types-big_numbers-mod_utils.adb deleted file mode 100644 index 3c02df1..0000000 --- a/src/crypto-types-big_numbers-mod_utils.adb +++ /dev/null @@ -1,741 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - -with Crypto.Types.Random; -with Crypto.Asymmetric.Prime_Tables; ---with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; -with Ada.Text_IO; - -separate(Crypto.Types.Big_Numbers) - -package body Mod_Utils is - - pragma Optimize (Time); - use Crypto.Asymmetric.Prime_Tables; - - - --------------------------------------------------------------------------- - - function Patch(Item, N : Big_Unsigned) - return Big_Unsigned is - Diff : constant Big_Unsigned:=((Big_Unsigned_Last - N) + 1) mod N; - begin - return Add(Item,Diff,N); - end Patch; pragma Inline(Patch); - - --------------------------------------------------------------------------- - - function Add(Left, Right, N : Big_Unsigned) return Big_Unsigned is - L : constant Big_Unsigned := Left mod N; - R : constant Big_Unsigned := Right mod N; - Result : constant Big_Unsigned := L + R; - begin - if Result < Max(L,R) then - return Patch(Result,N); - else return - Result mod N; - end if; - end Add; - - --------------------------------------------------------------------------- - - function Sub(Left, Right, N : Big_Unsigned) return Big_Unsigned is - L : constant Big_Unsigned := Left mod N; - R : constant Big_Unsigned := Right mod N; - begin - if R > L then - return N - R + L; - else return L-R; - end if; - end Sub; - - --------------------------------------------------------------------------- - - function Div(Left, Right, N : Big_Unsigned) return Big_Unsigned is - begin - return Mult(Left,Inverse(Right,N),N); - end Div; pragma Inline(Div); - - - --------------------------------------------------------------------------- - - --from Erik-Zenners handout "Zahlentheoretische Algorithmen" - function Pow(Base, Exponent, N : Big_Unsigned) return Big_Unsigned is - L : constant Big_Unsigned := Base mod N; - R : constant Big_Unsigned := Exponent; - Result : Big_Unsigned := Big_Unsigned_One; - begin - if L = Big_Unsigned_Zero or L = Big_Unsigned_One then - return L; - elsif R = Big_Unsigned_Zero then return Big_Unsigned_One; - else - -- Square_And_Muliply - for I in reverse 0..Bit_Length(R)-1 loop - Result := Mult(Result,Result,N); - if (Shift_Right(R, I) mod 2) = Big_Unsigned_One then - Result := Mult(Result,L,N); - end if; - end loop; - return Result mod N; - end if; - end Pow; - - --------------------------------------------------------------------------- - - --based on Erik-Zenners handout "Zahlentheoretische Algorithmen" - -- (ext. Euklid) - -- This function returns Big_unsigned_Zero if X have no inverse mod n - function Inverse(X, N : Big_Unsigned) return Big_Unsigned is - B : Big_Unsigned := X mod N; - A : Big_Unsigned := N; - begin - -- if gcd(A,B) /= 1 then A have no inverse mod B - if B = Big_Unsigned_Zero or A = Big_Unsigned_Zero or - Gcd(A,B) /= Big_Unsigned_One then - return Big_Unsigned_Zero; - end if; - - declare - T : Big_Unsigned := Big_Unsigned_One; - Tstrich, Tempt : Big_Unsigned; - Q, R : Big_Unsigned; - begin - loop - Big_Div(A,B,Q,R); - if(R = Big_Unsigned_Zero) then - return T; - end if; - - A:=B; - B:=R; - - Tempt:=T; - - T:=Sub(Tstrich,Mult(Q,T,N),N); - - Tstrich:=Tempt; - end loop; - end; - end Inverse; - - --------------------------------------------------------------------------- - - function Get_Random(N : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - begin - Random.Read(Result.Number); - - for I in reverse 0..N.Last_Index loop - if Result.Number(I) /= 0 then - Result.Last_Index := I; - exit; - end if; - end loop; - return Result mod N ; - end Get_Random; - - --------------------------------------------------------------------------- - - -- this function returns true if X is a Mersenne prim number - function Lucas_Lehmer_Test(X : Big_Unsigned) return Boolean is - Is_Mp : Boolean := false; - begin - - if X.Last_Index = 0 then - for I in 2..Word'Size-1 loop - if X.Number(0) = Shift_Left(2,I)-1 then - Is_Mp := True; - exit; - end if; - end loop; - if Is_Mp = False then return False; - end if; - else - for I in 0..X.Last_Index loop - if X.Number(I) /= Word'Last then return False; - end if; - end loop; - end if; - - declare - P : constant Word := Word(Bit_Length(X)-1); - S : Big_Unsigned := Big_Unsigned_Two+2; --S(1) = 4; - begin - for I in 2..P-1 loop - S := (Mult(S,S,X) - 2) mod X; - end loop; - - if S = Big_Unsigned_Zero then return True; - else return False; - end if; - end; - end Lucas_Lehmer_Test; - - --------------------------------------------------------------------------- - - --from Erik-Zenners handout "Zahlentheoretische Algorithmen" - function Is_Miller_Rabin_Witness(Wit, X : Big_Unsigned) return Boolean is - - B : constant Big_Unsigned := X-1; - Result : Big_Unsigned := Big_Unsigned_One; - Root : Big_Unsigned; - begin - for I in reverse 0..Bit_Length(B)-1 loop - Root := Result; - Result := Mult(Result, Result, X); - if ((Result = Big_Unsigned_One) and - (Root /= Big_Unsigned_One and Root /= B)) then return True; - elsif (Shift_Right(B,I) mod 2) = Big_Unsigned_One then - Result := Mult(Result, Wit, X); - end if; - end loop; - if Result /= Big_Unsigned_One then return True; - else return False; - end if; - end Is_Miller_Rabin_Witness; - - --------------------------------------------------------------------------- - - -- Test if Wit is a witness for N - -- If Wit is a wittness then N is no prime - function Is_Simple_Witness(Wit, N : Big_Unsigned) return Boolean is - begin - -- is Wit a "Miller-Rabin"-witness - if (Wit /= (N-Big_Unsigned_One)) and (Wit /= Big_Unsigned_One) and - Mult(Wit,Wit,N) = Big_Unsigned_One then return True; - - elsif Gcd(Wit,N) /= Big_Unsigned_One then return True; - - -- is Wit a "Fermat-Witness" - -- elsif Pow(Wit,N-1,N) /= Big_Unsigned_One then return True; - else return False; - end if; - end Is_Simple_Witness; - - --------------------------------------------------------------------------- - - - -- Returns true if N passes the specified number of Miller-Rabin tests. - function Passed_Miller_Rabin_Test(X : Big_Unsigned; S : Positive) - return Boolean is - Witness : Big_Unsigned; - begin - -- Do the tests - for I in 1..S loop - -- Generate a uniform random on (1, X) - loop - Witness := Get_Random(X); - exit when Witness > Big_Unsigned_One; - end loop; - if Is_Miller_Rabin_Witness(Witness, X) then - return False; - end if; - end loop; - return true; - end Passed_Miller_Rabin_Test; - - --------------------------------------------------------------------------- - - function Pass_Prime_Test(X : Big_Unsigned; Status : Hardness) - return Boolean is - Rounds : Natural; - X_Bit_Size : constant Natural := Bit_Length(X); - begin - if X < Big_Unsigned_Two then return False; - elsif Is_Even(X) then - if X = Big_Unsigned_Two then return True; - else return False; - end if; - end if; - - --X is odd - - for I in One_Digit_Primes'First+1..One_Digit_Primes'Last loop - if X = Word(One_Digit_Primes(I)) then return true; - elsif X mod Word(One_Digit_Primes(I)) = Big_Unsigned_Zero then - return False; - end if; - end loop; - - for I in Two_Digit_Primes'Range loop - if X = Word(Two_Digit_Primes(I)) then return true; - elsif X mod Word(Two_Digit_Primes(I)) = Big_Unsigned_Zero then - return False; - end if; - end loop; - - if Lucas_Lehmer_Test(X) then - return True; - end if; - - for I in Three_Digit_Primes'Range loop - if X = Word(Three_Digit_Primes(I)) then return true; - elsif X mod Word(Three_Digit_Primes(I)) = Big_Unsigned_Zero then - return False; - end if; - end loop; - - -- The relationship between the certainty and the number of rounds - -- we perform is given in the draft standard ANSI X9.80, "PRIME - -- NUMBER GENERATION, PRIMALITY TESTING, AND PRIMALITY CERTIFICATES". - -- Comment: - -- I don't have a look on this paper. =:) I borrowed this - -- "algorithmen" from the j2sdk1.4.1 library (java/math/BigInteger.java) - -- If you have the permission to send me the draft standard ANSI X9.80 - -- then send it, please! - -- I'm a student. I have no money for ANSI or IEEE drafts. :-( - -- It's right to require money to read a draft? - -- This really really sucks! SCNR! - - if (X_Bit_Size < 100) then Rounds := 50; - elsif (X_Bit_Size < 256) then Rounds := 27; - elsif (X_Bit_Size < 512) then Rounds := 15; - elsif (X_Bit_Size < 768) then Rounds := 8; - elsif (X_Bit_Size < 1024) then Rounds := 4; - else Rounds := 2; - end if; - - declare - Witness : Big_Unsigned; - begin - if Status = Weak then - for I in 1..Rounds loop - loop - Witness := Get_Random(X); - exit when Witness > Big_Unsigned_Two; - end loop; - if Is_Simple_Witness(Witness,X) then return False; - end if; - end loop; - else - for I in 1..Rounds loop - loop - Witness := Get_Random(X); - exit when Witness > Big_Unsigned_Two; - end loop; - if Is_Miller_Rabin_Witness(Witness,X) then return False; - end if; - end loop; - end if; - end; - return True; - end Pass_Prime_Test; - - --------------------------------------------------------------------------- - - - function Is_Prime(X : Big_Unsigned) return Boolean is - begin - return Pass_Prime_Test(X, Strong); - end Is_Prime; pragma Inline (Is_Prime); - - --------------------------------------------------------------------------- - - -- This function is faster then Is_prime but a lot of no strong pseudo - -- primes pass this test - function Looks_Like_A_Prime(X : Big_Unsigned) return Boolean is - begin - return Pass_Prime_Test(X, Weak); - end Looks_Like_A_Prime; pragma Inline(Looks_Like_A_Prime); - - --------------------------------------------------------------------------- - - function Get_Prime(N : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned := Get_Random(N); - begin - if N <= Big_Unsigned_Two then - raise Constraint_Error; - end if; - - -- make sure that Result is odd - Result.Number(0) := Result.Number(0) or 1; - loop - if Is_Prime(Result) then return Result; - else Result := (Result+2) mod N ; - end if; - end loop; - end Get_Prime; - - - --------------------------------------------------------------------------- - - - function "mod"(Left : D_Big_Unsigned; Right : Big_Unsigned) - return Big_Unsigned; - - --------------------------------------------------------------------------- - - -- Result = Left * Right (mod N) - function Mult(Left, Right, N : Big_Unsigned) return Big_Unsigned is - T : DWord; - Carry : Word := 0; - R : D_Big_Unsigned; - begin - for I in 0..Left.Last_Index loop - for J in 0..Right.Last_Index loop - T := DWord(Left.Number(I)) * DWord(Right.Number(J)) - + DWord(R.Number(I+J)) + DWord(Carry); - - R.Number(I+J) := Word(T and DWord(Word'Last)); - - Carry:= Word(Shift_Right(T,Word'Size)); - end loop; - R.Number(I+Right.Last_Index+1) := Carry + - R.Number(I+Right.Last_Index+1); - Carry := 0; - end loop; - - for I in reverse 0..D_Max_Length loop - if R.Number(I) /= 0 then - R.Last_Index := I; - exit; - end if; - end loop; - return R mod N; - end Mult; - - --------------------------------------------------------------------------- - - - -- Returns a probability N-bit prime (Result). - function Get_N_Bit_Prime(N : Positive) return Big_Unsigned is - J : Big_Unsigned := Get_Random(Shift_Left(Big_Unsigned_One,N-2)); - Index : constant Natural := (N-1)/Word'Size; - Amount : constant Natural := (N-1) mod Word'Size; - Result : Big_Unsigned := Shift_Left(J,1); - - begin - if N = 1 or N > Size then - raise Constraint_Error; - end if; - - loop - -- Make sure that Result is an odd - Set_Least_Significant_Bit (Result); - - -- Make sure that Result is a N-Bit-Number; - Result.Number (Index) := Result.Number (Index) or - Shift_Left (Word (1), Amount); - - if Amount = 0 then - Result.Last_Index := Index; - end if; - - if Is_Prime(Result) then - return Result; - else - Result:=Result-2; - if Is_Prime(Result) then - return Result; - end if; - end if; - - J := Get_Random (Shift_Left (Big_Unsigned_One, N - 2)); - Result := Shift_Left (J, 1); - end loop; - - end Get_N_Bit_Prime; - - --------------------------------------------------------------------------- - - -- computes the jacobi-symbol - -- return value: - -- 0 : if X mod N = 0 - -- 1 : if X is a quadratic resuide mod N - -- -1 : if X is a quadratic non-resuide mod N - - function Jacobi(X, N : Big_Unsigned) return Integer is - A : Big_Unsigned := X mod N; - begin - - if Is_Even(N) then - raise Constraint_Error; - end if; - - if N = Big_Unsigned_One then return 1; - elsif A = Big_Unsigned_Zero then return 0; - elsif A = Big_Unsigned_One then return 1; - end if; - - while (A mod 4) = Big_Unsigned_Zero loop - exit when (A mod 4) = Big_Unsigned_Zero; - A := Shift_Right(A,2); - end loop; - - if Is_Even(A) then - if (N mod 8 = 1) or (N mod 8 = 7) then - return Jacobi(Shift_Right(A,1),N); - else return -1*Jacobi(Shift_Right(A,1),N); - end if; - else - if (A mod 4 = 1) or (N mod 4 = 1) then - return Jacobi(N mod A, A); - else return -1*Jacobi(N mod A, A); - end if; - end if; - end Jacobi; - - ---------------------------------------------------------------------------- - -----------------------------DOUBLE_SIZE------------------------------------ - ---------------------------------------------------------------------------- - - --only needed for multiplication mod N - --here we need 2*Size-bit numbers to avoid an overflow because - --if one of our provisional result t > BIG_Unsigned_Last - --then there ist no well known algortihm to compute the - -- result of an multiplication mod m - - -- same algorithm for D_Big_Unsigned as for Big_Unsigned - - function "="(Left, Right : D_Big_Unsigned) return Boolean is - begin - if Left.Last_Index = Right.Last_Index then - for I in 0..Left.Last_Index loop - if Left.Number(I) /= Right.Number(I) then return False; - end if; - end loop; - else return False; - end if; - return True; - end"="; - - ---------------------------------------------------------------------------- - - function Shift_Left(Value : D_Big_Unsigned; Amount : Natural) - return D_Big_Unsigned is - begin - if Amount >= (D_Max_Length+1)*Word'Size or - Value = D_Big_Unsigned_Zero - then return D_Big_Unsigned_Zero; - elsif Amount = 0 then return Value; - end if; - - declare - Result : D_Big_Unsigned; - Temp : DLimbs :=(others => 0); - L : constant Natural := Amount mod Word'Size; - R : constant Natural := Word'Size-L; - M : constant Natural := Amount/Word'Size; - begin - Temp(0) := Shift_Left(Value.Number(0), L); - - for I in 1..Value.Last_Index loop - Temp(I) := Shift_Right(Value.Number(I-1), R) + - Shift_Left(Value.Number(I), L); - end loop; - - if Value.Last_Index /= D_Max_Length then - Temp(Value.Last_Index+1):= - Shift_Right(Value.Number(Value.Last_Index), R); - end if; - - for I in Temp'Range loop - if (I+M) > D_Max_Length then - exit; - end if; - Result.Number(I+M):= Temp(I); - end loop; - - for I in reverse 0..D_Max_Length loop - if Result.Number(I) /=0 then - Result.Last_Index:=I; - exit; - end if; - end loop; - return Result; - end; - end Shift_Left; pragma Inline (Shift_Left); - - --------------------------------------------------------------------------- - - - function Bit_Length(X : D_Big_Unsigned) return Natural is - begin - if X = D_Big_Unsigned_Zero then - return 0; - end if; - - for I in reverse 0..Word'Size-1 loop - if Shift_Left(1,I) <= X.Number(X.Last_Index) then - return Word'Size * X.Last_Index + I + 1 ; - end if; - end loop; - return X.Last_Index * Word'Size; - end Bit_Length; pragma Inline (Bit_Length); - - - --------------------------------------------------------------------------- - - function "<"(Left, Right : D_Big_Unsigned) return Boolean is - begin - if Left.Last_Index < Right.Last_Index then return True; - elsif Left.Last_Index > Right.Last_Index then return False; - else - for I in reverse 0..Left.Last_Index loop - if Left.Number(I) < Right.Number(I) then return True; - elsif Left.Number(I) > Right.Number(I) then return False; - end if; - end loop; - end if; - return False; - end "<"; pragma Inline ("<"); - - --------------------------------------------------------------------------- - - function ">"(Left, Right : D_Big_Unsigned) return Boolean is - begin - return Right < Left; - end ">"; pragma Inline (">"); - - - - --------------------------------------------------------------------------- - - function ">="(Left, Right : D_Big_Unsigned) return Boolean is - begin - return not(Left < Right); - end ">="; pragma Inline (">="); - - --------------------------------------------------------------------------- - - function "+"(Left, Right : D_Big_Unsigned) return D_Big_Unsigned; - - function "-"(Left, Right : D_Big_Unsigned) return D_Big_Unsigned is - begin - if Left = Right then return D_Big_Unsigned_Zero; - elsif Left = Right+D_Big_Unsigned_One then return D_Big_Unsigned_One; - elsif Left+D_Big_Unsigned_One = Right then return D_Big_Unsigned_Last; - - -- add the modulus if Right > Left - elsif Right > Left then - return D_Big_Unsigned_Last - Right + Left + D_Big_Unsigned_One; - else - declare - Result : D_Big_Unsigned; - Carry : Word:=0; - begin - -- Remember Left > Right - for I in 0..Left.Last_Index loop - Result.Number(I) := Left.Number(I) - Right.Number(I) - Carry; - if (Right.Number(I) > Left.Number(I)) or - (Carry= 1 and Right.Number(I) = Left.Number(I)) - then Carry :=1; - else Carry :=0; - end if; - if Result.Number(I) /= 0 then - Result.Last_Index := I; - end if; - end loop; - return Result; - end; - end if; - end "-"; - - - --------------------------------------------------------------------------- - - function "mod"(Left : D_Big_Unsigned; Right : Big_Unsigned) - return Big_Unsigned is - begin - if Left.Last_Index <= Max_Length then - declare - L : Big_Unsigned; - begin - L.Last_Index := Left.Last_Index; - L.Number(0..Left.Last_Index) := Left.Number(0..Left.Last_Index); - return L mod Right; - end; - end if; - - if Right = Big_Unsigned_Zero then raise Division_By_Zero; - --elsif Right = Big_Unsigned_One then return Big_Unsigned_Zero; - end if; - - -- Now, there is only the case where (Left > Right), (Right /= 0) - -- and |Left|>|Right|. - - declare - Remainder : D_Big_Unsigned:=Left; - Temp_Right, R : D_Big_Unsigned; - Result : Big_Unsigned; - Diff: Natural; - - begin - Temp_Right.Last_Index := Right.Last_Index; - Temp_Right.Number(0..Right.Last_Index) := - Right.Number(0..Right.Last_Index); - R:=Temp_Right; - - while(Remainder >= R) loop - Diff := Bit_Length(Remainder) - Bit_Length(R); - if Diff = 0 then - Remainder := Remainder-R; - exit; - else Diff:=Diff-1; - end if; - Temp_Right := Shift_Left(R, Diff); - Remainder := Remainder-Temp_Right; - end loop; - - Result.Last_Index := Remainder.Last_Index; - Result.Number(0..Result.Last_Index) := - Remainder.Number(0..Result.Last_Index); - return Result; - end; - end "mod"; - - --------------------------------------------------------------------------- - - function "+"(Left, Right : D_Big_Unsigned) return D_Big_Unsigned is - Result : D_Big_Unsigned; - M : constant Natural := Natural'Max(Left.Last_Index, Right.Last_Index); - Temp : Word; - Carry : Word :=0; - begin - - for I in 0..M loop - Temp :=Carry; - Result.Number(I) := Left.Number(I) + Right.Number(I) +Temp; - if Result.Number(I) < Word'Max(Left.Number(I), Right.Number(I)) - then Carry := 1; - else Carry := 0; - end if; - end loop; - - if Carry =1 and M < Max_Length then - Result.Number(M+1) := 1; - Result.Last_Index := M+1; - else - -- Set Result.Last_Index - for I in reverse 0..M loop - if Result.Number(I) /= 0 then - Result.Last_Index := I; - return Result; - end if; - end loop; - end if; - return Result; - end "+"; - - --------------------------------------------------------------------------- - -end Mod_Utils; diff --git a/src/crypto-types-big_numbers-utils.adb b/src/crypto-types-big_numbers-utils.adb deleted file mode 100644 index 313ce9b..0000000 --- a/src/crypto-types-big_numbers-utils.adb +++ /dev/null @@ -1,704 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - ---with Ada.Integer_Text_IO; ---with Ada.Strings.Unbounded.Text_IO; -with Crypto.Types.Random; - -SEPARATE(Crypto.Types.Big_Numbers) - -package body Utils is - - pragma Optimize (Time); - - --------------------------------------------------------------------------- - - procedure Swap(X, Y : in out Big_Unsigned) is - Temp : constant Big_Unsigned := X; - begin - X := Y; - Y := Temp; - end Swap; pragma Inline (Swap); - - --------------------------------------------------------------------------- - - procedure Set_Least_Significant_Bit(X : in out Big_Unsigned) is - begin - X.Number(0) := X.Number(0) or 1; - end Set_Least_Significant_Bit; pragma Inline(Set_Least_Significant_Bit); - - --------------------------------------------------------------------------- - - function Is_Odd(X : Big_Unsigned) return Boolean is - begin - if (X.Number(0) and 1) = 1 then return True; - else return False; - end if; - end Is_Odd; pragma Inline(Is_Odd); - - --------------------------------------------------------------------------- - - function Is_Even(X : Big_Unsigned) return Boolean is - begin - if (X.Number(0) and 1) = 0 then return True; - else return False; - end if; - end Is_Even; pragma Inline(Is_Even); - - --------------------------------------------------------------------------- - - procedure Set_Most_Significant_Bit(X : in out Big_Unsigned) is - begin - X.Last_Index := Max_Length; - X.Number(Max_Length) := X.Number(Max_Length) or - Shift_Left(Word(1), Word'Size-1); - end Set_Most_Significant_Bit; pragma Inline(Set_Most_Significant_Bit); - - - --------------------------------------------------------------------------- - - function Bit_Length(X : Big_Unsigned) return Natural is - begin - if X = Big_Unsigned_Zero then - return 0; - end if; - - for I in reverse 0..Word'Size-1 loop - if Shift_Left(1,I) <= X.Number(X.Last_Index) then - return Word'Size * X.Last_Index + I + 1 ; - end if; - end loop; - return X.Last_Index * Word'Size; - end Bit_Length; pragma Inline(Bit_Length); - - --------------------------------------------------------------------------- - - function Lowest_Set_Bit(X : Big_Unsigned) return Natural is - begin - if X = Big_Unsigned_Zero then - raise Is_Zero_Error; - end if; - - for I in 0..X.Last_Index loop - if X.Number(I) /= 0 then - for J in 0..Word'Size-1 loop - if (Shift_Right(X.Number(I),J) and 1) = 1 then - return I*Word'Size+J+1; - end if; - end loop; - end if; - end loop; - return Size+1; --X = Big_unsgned_Zero = 2**(Size+1) - end Lowest_Set_Bit; pragma Inline (Lowest_Set_Bit); - - - --------------------------------------------------------------------------- - - - procedure Inc(X : in out Big_Unsigned) is - begin - if X = Big_Unsigned_Last then - X := Big_Unsigned_Zero; - else - X.Number(0) := X.Number(0) + 1; - for I in 0..X.Last_Index loop - if X.Number(I) /= 0 then - exit; - else X.Number(I+1) := X. Number(I+1) + 1; - end if; - end loop; - - -- if an mod_type overflow occure then we have some extra work do - if X.Number(X.Last_Index) = 0 then - X.Last_Index := X.Last_Index + 1; - end if; - end if; - end Inc; pragma Inline(Inc); - - --------------------------------------------------------------------------- - - procedure Dec(X : in out Big_Unsigned) is - begin - if X = Big_Unsigned_Zero then - X := Big_Unsigned_Last; - else - X.Number(0) := X.Number(0) - 1; - for I in 0..X.Last_Index loop - if X.Number(I) /= Word'Last then - exit; - else X.Number(I+1) := X.Number(I+1) - 1; - end if; - end loop; - - - -- check if we must dec the Last_index too - if X.Number(X.Last_Index) = 0 and X.Last_Index /= 0 then - X.Last_Index := X.Last_Index - 1; - end if; - end if; - end Dec; pragma Inline(Dec); - - --------------------------------------------------------------------------- - - function Shift_Left(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned is - begin - if Amount >= (Max_Length+1)*Word'Size or Value = Big_Unsigned_Zero - then return Big_Unsigned_Zero; - elsif Amount = 0 then return Value; - end if; - - declare - Result : Big_Unsigned; - Temp : Limbs:=(others => 0); - L : constant Natural := Amount mod Word'Size; - R : constant Natural := Word'Size-L; - M : constant Natural := Amount/Word'Size; - begin - Temp(0) := Shift_Left(Value.Number(0), L); - --- for I in 1..Value.Last_Index loop --- Temp(I) := Shift_Right(Value.Number(I-1), R) + --- Shift_Left(Value.Number(I), L); --- end loop; - for I in 1..Value.Last_Index loop - Temp(I) := Shift_Right(Value.Number(I-1), R) xor - Shift_Left(Value.Number(I), L); - end loop; - - if Value.Last_Index /= Max_Length then - Temp(Value.Last_Index+1):= - Shift_Right(Value.Number(Value.Last_Index), R); - end if; - - for I in Temp'Range loop - if (I+M) > Max_Length then - exit; - end if; - Result.Number(I+M):= Temp(I); - end loop; - for I in reverse 0..Max_Length loop - if Result.Number(I) /=0 then - Result.Last_Index:=I; - exit; - end if; - end loop; - return Result; - end; - end Shift_Left; -- pragma Inline (Shift_Left); - - --------------------------------------------------------------------------- - - function Shift_Right(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned is - begin - if Amount >= (Max_Length+1)*Word'Size or Value = Big_Unsigned_Zero - then return Big_Unsigned_Zero; - elsif Amount = 0 then return Value; - end if; - - declare - Result : Big_Unsigned:=Big_Unsigned_Zero; - Temp : Limbs :=(others => 0); - R : constant Natural := Amount mod Word'Size; - L : constant Natural := Word'Size-R; - M : constant Natural := Amount/Word'Size; - begin - Temp(Value.Last_Index) := - Shift_Right(Value.Number(Value.Last_Index), R); - --- for I in reverse 0..Value.Last_Index-1 loop --- Temp(I) := Shift_Left(Value.Number(I+1), L) + --- Shift_Right(Value.Number(I), R); --- end loop; - for I in reverse 0..Value.Last_Index-1 loop - Temp(I) := Shift_Left(Value.Number(I+1), L) xor - Shift_Right(Value.Number(I), R); - end loop; - - for I in reverse Temp'Range loop - if (I-M) < 0 then - exit; - end if; - Result.Number(I-M):= Temp(I); - end loop; - - for I in reverse 0..Value.Last_Index loop - if Result.Number(I) /= 0 or I = 0 then - Result.Last_Index := I; - exit; - end if; - end loop; - return Result; - end; - end Shift_Right; --pragma Inline (Shift_Right); - - - --------------------------------------------------------------------------- - - function Rotate_Left(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned is - L : constant Natural := Amount mod Size; - begin - if Value = Big_Unsigned_Last then - return Big_Unsigned_Last; - end if; - return Shift_Left(Value,L) xor Shift_Right(Value, Size-L); - end Rotate_Left; pragma Inline (Rotate_Left); - - --------------------------------------------------------------------------- - - function Rotate_Right(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned is - R : constant Natural := Amount mod Size; - begin - if Value = Big_Unsigned_Last then - return Big_Unsigned_Last; - end if; - return Shift_Right(Value,R) xor Shift_Left(Value, Size-R); - end Rotate_Right; pragma Inline (Rotate_Right); - - --------------------------------------------------------------------------- - - function Gcd(Left, Right : Big_Unsigned) return Big_Unsigned is - A : Big_Unsigned := Max(Left,Right); - B : Big_Unsigned := Min(Left,Right); - R : Big_Unsigned; - begin - while B /= Big_Unsigned_Zero loop - R := A mod B; - A := B; - B := R; - end loop; - return A; - end Gcd; pragma Inline (Gcd); - - --------------------------------------------------------------------------- - - function Get_Random return Big_Unsigned is - Result : Big_Unsigned; - begin - Random.Read(Result.Number); - return Result; - end Get_Random; pragma Inline (Get_Random); - - --------------------------------------------------------------------------- - - function Length_In_Bytes(X : Big_Unsigned) return Natural is - Len : constant Natural := Bit_Length(X); - begin - if Len mod Byte'Size = 0 then return (Len / Byte'Size); - else return (Len / Byte'Size) + 1; - end if; - end Length_In_Bytes; pragma Inline (Length_In_Bytes); - - --------------------------------------------------------------------------- - - function To_Big_Unsigned(X : Word) return Big_Unsigned is - Result : constant Big_Unsigned := - (Last_Index => 0, Number => (0 => X, OTHERS => 0)); - begin - return Result; - end To_Big_Unsigned; pragma Inline (To_Big_Unsigned); - - - function To_Words(X : Big_Unsigned) return Words is - begin - return X.Number(0..X.Last_Index); - end To_Words; pragma Inline (To_Words); - - - --------------------------------------------------------------------------- - - function Max(Left, Right : Integer) return Integer is - begin - if Left < Right then - return Right; - else - return Left; - end if; - end Max; - - - --------------------------------------------------------------------------- - - function To_Bytes(X : Big_Unsigned) return Bytes is - L : constant Natural := Max(Length_In_Bytes(X)-1,0); - M : constant Natural := 3; --(Word'Size / Byte'Size) - 1; - E : constant Integer := ((L+1) mod 4) - 1; - B : Bytes(0..L); - begin - for I in 0..X.Last_Index-1 loop - for J in 0..M loop - B(L-I*(M+1)-J) := Byte(Shift_Right(X.Number(I), J*Byte'Size) and - Word(Byte'Last)); - end loop; - end loop; - - if E >= 0 then - for I in 0..E loop - B(I) := Byte(Shift_Right(X.Number(X.Last_Index), (E-I)*Byte'Size) - and Word(Byte'Last)); - end loop; - else - for J in 0..M loop - B(M-J) := Byte(Shift_Right(X.Number(X.Last_Index), J*Byte'Size) - and Word(Byte'Last)); - end loop; - end if; - - return B; - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Big_Unsigned(X : Words) return Big_Unsigned is - Result : Big_Unsigned; - begin - if X'Length > Max_Length then - raise Constraint_Error; - else - Result.Number(0..X'Last-X'First) := X; - end if; - - for I in reverse 0..Max_Length loop - if Result.Number(I) /= 0 then - Result.Last_Index := I; - exit; - end if; - end loop; - - return Result; - end To_Big_Unsigned; - - --------------------------------------------------------------------------- - - function To_Big_Unsigned(X : Bytes) return Big_Unsigned is - Result : Big_Unsigned; - M : constant Natural := Word'Size / Byte'Size; -- Bytes per Word - Shift_Amount, counter : Natural:=0; - begin - if X'Length*Byte'Size > Size then - raise Constraint_Error; - end if; - - for I in reverse X'Range loop - Result.Number(Counter/M) := Result.Number(Counter/M) or - Shift_Left(Word(X(I)), Shift_Amount*Byte'Size); - Shift_Amount := (Shift_Amount + 1) mod M; - Counter:=Counter+1; - end loop; - - for I in reverse 0..Max_Length loop - if Result.Number(I) /= 0 then - Result.Last_Index := I; - exit; - end if; - end loop; - - return Result; - - end To_Big_Unsigned; - - --------------------------------------------------------------------------- - - procedure Big_Div(Dividend, Divisor : in Big_Unsigned; - Quotient, Remainder : out Big_Unsigned) is - Last_Divisor : constant Natural := Divisor.Last_Index; - begin - if (Last_Divisor = 0) then - case Divisor.Number(0) is - when 0 => raise Division_By_Zero; - when 1 => Quotient := Dividend; - Remainder := Big_Unsigned_Zero; - return; - when others => declare - Temp_Remainder : Word; - Temp_Divisor : constant Word := Divisor.Number(0); - begin - -- We use the function Short_Div, which is faster. - -- See below for the implementation of Short_Div. - Short_Div(Dividend, Temp_Divisor, Quotient, Temp_Remainder); - Remainder := (Last_Index => 0, - Number => (Temp_Remainder, others => 0)); - return; - end; - end case; - - elsif (Dividend < Divisor) then - Quotient := Big_Unsigned_Zero; - Remainder := Dividend; - return; - - elsif Dividend = Big_Unsigned_Zero then - Quotient := Big_Unsigned_Zero; - Remainder := Big_Unsigned_Zero; - return; - - elsif (Bit_Length(Dividend) = Bit_Length(Divisor)) then - -- Dividend > Divisor and Divisor /= 0 and - -- |Dividend|=|Divisor| => Dividend/Divisor=1 - Quotient:=Big_Unsigned_One; - Remainder:=Dividend-Divisor; - return; - end if; - - -- Now, there is only the case where (Dividend > Divisor), (Divisor /= 0) - -- and |Dividend|>|Divisor|. - - declare - Temp_Divisor: Big_Unsigned :=Divisor; - Diff: Natural; - begin - Remainder:= Dividend; - Quotient:=Big_Unsigned_Zero; - - while(Remainder >= Divisor) loop - Diff := Bit_Length(Remainder) - Bit_Length(Divisor); - if Diff = 0 then - Quotient:=Quotient+1; - Remainder:=Remainder-Divisor; - return; - else Diff:=Diff-1; - end if; - Temp_Divisor := Shift_Left(Divisor, Diff); - Remainder := Remainder-Temp_Divisor; - Quotient := Quotient + Shift_Left(Big_Unsigned_One, Diff); - end loop; - end; - end Big_Div; - - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - - procedure Short_Div(Dividend : in Big_Unsigned; - Divisor : in Word; - Quotient : out Big_Unsigned; - Remainder : out Word) is - begin - - -- simple cases - if (Dividend < Divisor) then - Remainder := Dividend.Number(0); - Quotient := Big_Unsigned_Zero; - return; - elsif (Divisor = 0) then - raise Division_By_Zero; - elsif (Divisor = 1) then - Quotient := Dividend; - Remainder := 0; - return; - elsif (Dividend = Divisor) then - Quotient := Big_Unsigned_One; - Remainder := 0; - return; - end if; - - declare - Last_Dividend : constant Natural := Dividend.Last_Index; - Temp_Quotient : Big_Unsigned; - Carry : Largest_Unsigned := 0; - Temp : Largest_Unsigned; - Temp_Divisor : constant Largest_Unsigned := - Largest_Unsigned(Divisor); - - begin - for I in reverse 0..Last_Dividend loop - Temp := Largest_Unsigned(Dividend.Number(I)) - + Shift_Left(Carry, Word'Size); - Temp_Quotient.Number(I) := Word(Temp / Temp_Divisor); - Carry := Temp mod Temp_Divisor; - end loop; - - if (Last_Dividend > 0) and then - (Temp_Quotient.Number(Last_Dividend) = 0) then - Temp_Quotient.Last_Index := Last_Dividend - 1; - else - Temp_Quotient.Last_Index := Last_Dividend; - end if; - Quotient := Temp_Quotient; - Remainder := Word(Carry); - end; - end Short_Div; - - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - --- package IIO renames Ada.Integer_Text_IO; --- package UIO renames Ada.Strings.Unbounded.Text_IO; - - --------------------------------------------------------------------------- - - function To_String(Item : Big_Unsigned; - Base : Number_Base := 10) return String is - S : Unbounded_String := Null_Unbounded_String; - Remainder : Word:=0; - Temp_Item : Big_Unsigned := Item; - Trans : constant array(Word range 0..15) of Character := - ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); - Base_Img : constant String := Base'Img; - begin - if Item = Big_Unsigned_Zero then - if Base = 10 then return "0"; - else - S := "#0#" & S; - S := Base_Img & S; - return Slice(S,2,Length(S)); - end if; - else - if Base /= 10 then - S := "#" & S; - end if; - while (Temp_Item /= Big_Unsigned_Zero) loop - Short_Div(Temp_Item, Word(Base), Temp_Item, Remainder); - S := Trans(Remainder) & S; - end loop; - if Base /= 10 then - S := "#" & S; - S := Base_Img & S; - return Slice(S,2,Length(S)); - end if; - end if; - return To_String(S); - end To_String; - - --------------------------------------------------------------------------- - - procedure Put(Item : in Big_Unsigned; Base : in Number_Base := 10) is - begin - Put(To_String(Item, Base)); - end Put; --pragma Inline(Put); - - --------------------------------------------------------------------------- - - procedure Put_Line(Item : in Big_Unsigned; Base : in Number_Base := 10) is - begin - Put(To_String(Item, Base)); New_Line; - end Put_Line; --pragma Inline(Put_Line); - - --------------------------------------------------------------------------- - - function Get_Digit(C : Character) return Word is - begin - case C is - when '0'..'9' => return Character'Pos(C) - Character'Pos('0'); - when 'A'..'F' => return Character'Pos(C) - Character'Pos('A') + 10; - when others => raise Conversion_Error; - end case; - end Get_Digit; pragma Inline(Get_Digit); - - --------------------------------------------------------------------------- - - function To_Big_Unsigned(S : String) return Big_Unsigned is - Fence_Count: Natural := 0; - Temp : Unbounded_String := Null_Unbounded_String; - M_B : Natural:=0; - begin - if S'Length = 0 then - raise Conversion_Error; - else - for I in reverse S'Range loop - case S(I) is - when '0' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,0); - when '1' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,1); - when '2' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,2); - when '3' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,3); - when '4' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,4); - when '5' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,5); - when '6' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,6); - when '7' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,7); - when '8' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,8); - when '9' => Temp:= S(I) & Temp; M_B:=Natural'Max(M_B,9); - when 'a' | 'A' => Temp:= 'A' & Temp; M_B:=Natural'Max(M_B,11); - when 'b' | 'B' => Temp:= 'B' & Temp; M_B:=Natural'Max(M_B,12); - when 'c' | 'C' => Temp:= 'C' & Temp; M_B:=Natural'Max(M_B,13); - when 'd' | 'D' => Temp:= 'D' & Temp; M_B:=Natural'Max(M_B,14); - when 'e' | 'E' => Temp:= 'E' & Temp; M_B:=Natural'Max(M_B,15); - when 'f' | 'F' => Temp:= 'F' & Temp; M_B:=Natural'Max(M_B,16); - when '_' | ' ' => null; - when '#' => Fence_Count := Fence_Count+1; Temp:= S(I) & Temp; - when others => raise Conversion_Error; - end case; - end loop; - end if; - - declare - Result : Big_Unsigned; - S2 : constant String := To_String(Temp); - begin - - -- Base = 10 - if Fence_Count = 0 then - if M_B > 10 then - raise Conversion_Error; - end if; - for I in S2'Range loop - Result := Result * 10 + Get_Digit(S2(I)); - end loop; - return Result; - - -- Base /= 10 - -- check fences and size (Min_Size=|2#0#|=4) - elsif Fence_Count /= 2 or S2(S2'Last) /= '#' or S2(S2'First) = '#' - or S2'Length < 4 then - raise Conversion_Error; - end if; - - declare - Base : Number_Base; - begin - --Compute and check Base - if S2(S2'First+1) /= '#' then - if S2(S2'First+2) /= '#' then - raise Conversion_Error; - end if; - Base := Number_Base(Get_Digit(S2(S2'First)) * 10 - + Get_Digit(S2(S2'First+1))); - else Base := Number_Base(Get_Digit(S2(S2'First))); - end if; - - -- Check if all Characters are valid to the base - if M_B > Base then - raise Conversion_Error; - end if; - - --Time to compute the Big_Unsigned - if Base > 10 then - for I in S2'First+3..S2'Last-1 loop - Result := Result * Word(Base) + Get_Digit(S2(I)); - end loop; - else - for I in S2'First+2..S2'Last-1 loop - Result := Result * Word(Base) + Get_Digit(S2(I)); - end loop; - end if; - return Result; - end; - end; - end To_Big_Unsigned; - - --------------------------------------------------------------------------- - - end Utils; - diff --git a/src/crypto-types-big_numbers.adb b/src/crypto-types-big_numbers.adb deleted file mode 100644 index b69e55b..0000000 --- a/src/crypto-types-big_numbers.adb +++ /dev/null @@ -1,921 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; - -package body Crypto.Types.Big_Numbers is - - -- package MIO is new Ada.Text_Io.Modular_IO (Word); - - --------------------------------------------------------------------------- - -----------------------SEPARATED_BODYS------------------------------------- - --------------------------------------------------------------------------- - - package body Utils is separate; - use Utils; - - package body Mod_Utils is separate; - use Mod_Utils; - - package body Binfield_Utils is separate; - use Binfield_Utils; - - --------------------------------------------------------------------------- - ---------------------------COMPARE_FUNCTIONS-------------------------------- - --------------------------------------------------------------------------- - - - --------------------------------------------------------------------------- - -- compare: Big_Unsigned with Big_Unsigned -- - --------------------------------------------------------------------------- - - - function "="(Left, Right : Big_Unsigned) return Boolean is - begin - if Left.Last_Index = Right.Last_Index then - for I in 0..Left.Last_Index loop - if Left.Number(I) /= Right.Number(I) then return False; - end if; - end loop; - else return False; - end if; - return True; - end "="; - - --------------------------------------------------------------------------- - - function "<"(Left, Right : Big_Unsigned) return Boolean is - begin - if Left.Last_Index < Right.Last_Index then return True; - elsif Left.Last_Index > Right.Last_Index then return False; - else - for I in reverse 0..Left.Last_Index loop - if Left.Number(I) < Right.Number(I) then return True; - elsif Left.Number(I) > Right.Number(I) then return False; - end if; - end loop; - end if; - return False; - end "<"; - - --------------------------------------------------------------------------- - - function ">"(Left, Right : Big_Unsigned) return Boolean is - begin - return Right < Left; - end ">"; - - --------------------------------------------------------------------------- - - function "<="(Left, Right : Big_Unsigned) return Boolean is - begin - return not (Right < Left); - end "<="; - - - --------------------------------------------------------------------------- - - - function ">="(Left, Right : Big_Unsigned) return Boolean is - begin - return not (Left < Right); - end ">="; - - --------------------------------------------------------------------------- - - function Min(X, Y : in Big_Unsigned) return Big_Unsigned is - begin - if (X < Y) then return X; - else return Y; - end if; - end Min; - - --------------------------------------------------------------------------- - - function Max(X, Y : in Big_Unsigned) return Big_Unsigned is - begin - if (X < Y) then return Y; - else return X; - end if; - end Max; - - - --------------------------------------------------------------------------- - -- compare: Big_Unsigned with Word -- - --------------------------------------------------------------------------- - - - function "="(Left : Big_Unsigned; Right : Word) return Boolean is - begin - if Left.Last_Index=0 and Left.Number(0) = Right then return True; - else return False; - end if; - end "="; - - --------------------------------------------------------------------------- - - function "="(Left : Word; Right : Big_Unsigned) return Boolean is - begin - return Right = Left; - end "="; - - --------------------------------------------------------------------------- - - function "<"(Left : Big_Unsigned; Right : Word) return Boolean is - begin - if Left.Last_Index > 0 then return False; - else return Left.Number(Left.Last_Index) < Right; - end if; - end "<"; - - --------------------------------------------------------------------------- - - function "<"(Left : Word; Right : Big_Unsigned) return Boolean is - begin - if Right.Last_Index > 0 then return True; - else return Left < Right.Number(Right.Last_Index); - end if; - end "<"; - - --------------------------------------------------------------------------- - - function ">"(Left : Big_Unsigned; Right : Word) return Boolean is - begin - return Right < Left; - end ">"; - - --------------------------------------------------------------------------- - - function ">"(Left : Word; Right : Big_Unsigned) return Boolean is - begin - return Right < Left; - end ">"; - - --------------------------------------------------------------------------- - - function "<="(Left : Big_Unsigned; Right : Word) return Boolean is - begin - return not (Right < Left); - end "<="; - - --------------------------------------------------------------------------- - - function "<="(Left : Word; Right : Big_Unsigned) return Boolean is - begin - return not (Right < Left); - end "<="; - - --------------------------------------------------------------------------- - - function ">="(Left : Big_Unsigned; Right : Word) return Boolean is - begin - return not (Left < Right); - end ">="; - - --------------------------------------------------------------------------- - - function ">="(Left : Word; Right : Big_Unsigned) return Boolean is - begin - return not (Left < Right); - end ">="; - - - --------------------------------------------------------------------------- - ----------------------------BASE_FUNCTIONS--------------------------------- - --------------------------------------------------------------------------- ---============================================================================-- - - function "+"(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - L : constant Natural := Natural'Max( Bit_Length(Left), Bit_Length(Right)); - begin - if L + 1 <= Word'Size then - Result.Number(0) := Left.Number(0) + Right.Number(0); - else - - declare - Carry : Big_Unsigned; - Temp : Big_Unsigned; - begin - Carry := Left and Right; - Result := Left xor Right; - Carry := Shift_Left(Carry,1); - loop - Temp := Result and Carry; - Result := Result xor Carry; - Carry := Temp; - Carry := Shift_Left(Carry,1); - exit when Carry = Big_Unsigned_Zero; - end loop; - end; - end if; - - return Result; - end "+"; - --- function "+"(Left, Right : Big_Unsigned) return Big_Unsigned is --- Result: Big_Unsigned; --- Carry : Big_Unsigned; --- Temp : Big_Unsigned; --- begin --- Carry := Left and Right; --- Result := Left xor Right; --- Carry := Shift_Left(Carry,1); --- --ADA Do_While --- loop --- Temp := Result and Carry; --- Result := Result xor Carry; --- Carry := Temp; --- Carry := Shift_Left(Carry,1); --- exit when Carry = Big_Unsigned_Zero; --- end loop; --- return Result; --- end "+"; --------------------------------------------------------------------------------- --- function "+"(Left, Right : Big_Unsigned) return Big_Unsigned is --- Result : Big_Unsigned; --- M : constant Natural := Natural'Max(Left.Last_Index, Right.Last_Index); --- Temp : Word; --- Carry : Word :=0; --- begin --- for I in 0..M loop --- Temp :=Carry; --- Result.Number(I) := Left.Number(I) + Right.Number(I) +Temp; --- if Result.Number(I) < Word'Max(Left.Number(I), Right.Number(I)) --- then Carry := 1; --- else Carry := 0; --- end if; --- end loop; - --- if Carry =1 and M < Max_Length then --- Result.Number(M+1) := 1; --- Result.Last_Index := M+1; --- else --- -- Set Result.Last_Index --- for I in reverse 0..M loop --- if Result.Number(I) /= 0 then --- Result.Last_Index := I; --- return Result; --- end if; --- end loop; --- end if; --- return Result; --- end "+"; ---============================================================================-- - --------------------------------------------------------------------------- - - function "+"(Left : Big_Unsigned; Right : Word) return Big_Unsigned is - Big_Right : Constant Big_Unsigned := - (Last_Index => 0, Number => (0 => Right, OTHERS => 0)); - begin - return Left + Big_Right; - end "+"; - - --------------------------------------------------------------------------- - - function "+"(Left : Word; Right : Big_Unsigned) return Big_Unsigned is - Big_Left : constant Big_Unsigned := (Last_Index => 0, Number => (0 => Left, OTHERS => 0)); - begin - return Big_Left + Right; - end "+"; - - --------------------------------------------------------------------------- - - function "-"(Left, Right : Big_Unsigned) return Big_Unsigned is - begin - -- Add the modulus if Right > Left - if Right > Left then - return Big_Unsigned_Last - Right + Left + 1; --- raise Big_Unsigned_Negative; -- RSA does not run - else - declare - Result : Big_Unsigned; - Carry : Word:=0; - begin - -- Remember: Left => Right - for I in 0..Left.Last_Index loop - Result.Number(I) := Left.Number(I) - Right.Number(I) - Carry; - if (Right.Number(I) > Left.Number(I)) or - (Carry= 1 and Right.Number(I) = Left.Number(I)) - then Carry :=1; - else Carry :=0; - end if; - if Result.Number(I) /= 0 then - Result.Last_Index := I; - end if; - end loop; - return Result; - end; - end if; - end "-"; - - --------------------------------------------------------------------------- - - function "-"(Left : Big_Unsigned; Right : Word) return Big_Unsigned is - Big_Right : constant Big_Unsigned := (Last_Index => 0, Number => (0 => Right, OTHERS => 0)); - begin - return Left - Big_Right; - end "-"; - - --------------------------------------------------------------------------- - - function "-"(Left : Word; Right : Big_Unsigned) return Big_Unsigned is - Big_Left : constant Big_Unsigned := (Last_Index => 0, Number => (0 => Left, OTHERS => 0)); - begin - return Big_Left - Right; - end "-"; - - --------------------------------------------------------------------------- - - function "-"(X : Big_Unsigned) return Big_Unsigned is - begin - if X /= Big_Unsigned_Zero then - return Big_Unsigned_Last-X-1; - else - return X; - end if; - end "-"; - - --------------------------------------------------------------------------- ---============================================================================-- - - function "*"(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned ; - L : constant Natural := Bit_Length(Left)+Bit_Length(Right); - begin - if L <= Word'Size then - Result.Number(0) := Left.Number(0) * Right.Number(0); - elsif L > 2800 and L <= 3600 then - Result := Karatsuba_P(Left, Right); - elsif L > 3600 then - Result := Toom_Cook_P(Left, Right); - else - declare - Temp : Big_Unsigned; - begin - for I in reverse 0..Left.Last_Index loop - Temp := Left.Number(I) * Right; - Temp := Shift_Left(Temp, (I*Word'Size)); - Result := Result + Temp; - end loop; - end; - end if; - return Result; - end "*"; --------------------------------------------------------------------------------- - - function Russ (Left,Right : Big_Unsigned)return Big_Unsigned is - Result : Big_Unsigned ; - begin - if Bit_Length(Left)+Bit_Length(Right) <= Word'Size then - Result.Number(0) := Left.Number(0) * Right.Number(0); - else - declare - AA : Big_Unsigned := Left; - BB : Big_Unsigned := Right; - begin - while AA > Big_Unsigned_Zero loop - if (AA and Big_Unsigned_One) = 1 then - Result := Result + BB; - AA := AA - 1; - end if; - AA := Shift_Right(AA, 1); - BB := Shift_Left(BB, 1); - end loop; - end; - end if; - return Result; - end Russ; - --------------------------------------------------------------------------------- - - function Karatsuba (Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - begin - if Bit_Length(Left)+Bit_Length(Right) < Word'Size then - Result.Number(0) := Left.Number(0) * Right.Number(0); - else - declare - Left_1, Left_2 : Big_Unsigned; - Right_1, Right_2 : Big_Unsigned; - P_1, P_2 : Big_Unsigned; - N : constant Natural := Natural'Max( Bit_Length(Left) - , Bit_Length(Right))/2; - begin - Left_1 := Shift_Right(Left, N); - Left_2 := Left - Shift_Left( Left_1, N ); - Right_1 := Shift_Right(Right, N); - Right_2 := Right - Shift_Left( Right_1, N ); - - P_1 := Left_1 * Right_1; - P_2 := Left_2 * Right_2; - Result := Shift_Left(P_1, 2*N) - + Shift_Left(((Left_1 + Left_2)*(Right_1 + Right_2)) - P_1 - P_2, N) - + P_2; - end; - end if; - return Result; - end Karatsuba; - - --------------------------------------------------------------------------------- - - function Karatsuba_P (Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - begin - if Bit_Length(Left)+Bit_Length(Right) < Word'Size then - Result.Number(0) := Left.Number(0) * Right.Number(0); - else - declare - Left_1, Left_2 : Big_Unsigned:= Big_Unsigned_Zero; - Right_1, Right_2 : Big_Unsigned:= Big_Unsigned_Zero; - P_1, P_2, P_3 : Big_Unsigned:= Big_Unsigned_Zero; - N : constant Natural := Natural'Max( Bit_Length(Left), - Bit_Length(Right))/2; - ----------------------------------------------------------------------- - task type Karatsuba_Task_Type is - entry Input (Left, Right : in Big_Unsigned); - entry Output(Result : out Big_Unsigned); - end Karatsuba_Task_Type; - task body Karatsuba_Task_Type is - X : Big_Unsigned; - Left_Local : Big_Unsigned; - Right_Local : Big_Unsigned; - begin - accept Input (Left, Right : Big_Unsigned) do - Left_Local := Left; - Right_Local := Right; - end Input; - --- X := Karatsuba(Left_Local, Right_Local); - X := Left_Local * Right_Local; - - accept Output(Result : out Big_Unsigned) do - Result := X; - end Output; - end Karatsuba_Task_Type; - Task_1 : Karatsuba_Task_Type; - Task_2 : Karatsuba_Task_Type; - Task_3 : Karatsuba_Task_Type; - ----------------------------------------------------------------------- - begin - Left_1 := Shift_Right(Left, N); - Left_2 := Left - Shift_Left( Left_1, N ); - Right_1 := Shift_Right(Right, N); - Right_2 := Right - Shift_Left( Right_1, N ); - - Task_1.Input(Left_1, Right_1); - Task_2.Input(Left_2, Right_2); - Task_3.Input((Left_1 + Left_2), (Right_1 + Right_2)); - - Task_1.Output(Result => P_1); - Task_2.Output(Result => P_2); - Task_3.Output(Result => P_3); - - Result := Shift_Left(P_1, 2*N) - + Shift_Left((P_3 - P_1 - P_2), N) - + P_2; - end; - end if; - return Result; - end Karatsuba_P; - - ----------------------------------------------------------------------- - - function Toom_Cook(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - begin - if Bit_Length(Left)+Bit_Length(Right) < Word'Size then - Result.Number(0) := Left.Number(0) * Right.Number(0); - else - - declare - knuth_1 : Array (1..5) of Big_Unsigned; - knuth_2 : Array (1..4) of Big_Unsigned; - knuth_3 : Array (1..3) of Big_Unsigned; - knuth_4 : Array (1..2) of Big_Unsigned; - knuth_5_1 : Big_Unsigned; - L, R : Array (0..3) of Big_Unsigned; - F_Left, F_Right : Array (2..4) of Big_Unsigned; - Z : Array (0..4) of Big_Unsigned; - Length : constant Natural := Natural'Max( Bit_Length(Left) , - Bit_Length(Right) ); - N : constant Natural := Length / 3; - DN : constant Natural := 2 * N; - - begin - - -- SPLITTING ............................................................. - - L(0) := Shift_Right( Left, DN); - L(1) := Shift_Right( Left, N ) - Shift_Left( L(0), N ); - L(2) := Left - Shift_Left( L(0), DN ) - Shift_Left( L(1), N ); - R(0) := Shift_Right( Right, DN); - R(1) := Shift_Right( Right, N ) - Shift_Left( R(0), N ); - R(2) := Right - Shift_Left( R(0), DN ) - Shift_Left( R(1), N ); - - F_Left(2) := Shift_Left(L(0),2) + Shift_Left(L(1),1) + L(2); - F_Right(2) := Shift_Left(R(0),2) + Shift_Left(R(1),1) + R(2); - F_Left(3) := (Shift_Left(L(0),3) + L(0)) + (Shift_Left(L(1),1)+L(1)) + L(2); - F_Right(3) := (Shift_Left(R(0),3) + R(0)) + (Shift_Left(R(1),1)+R(1)) + R(2); - F_Left(4) := Shift_Left(L(0),4) + Shift_Left(L(1),2) + L(2); - F_Right(4) := Shift_Left(R(0),4) + Shift_Left(R(1),2) + R(2); - - -- INTERPOLATION with POINTWISE MULT ..................................... - - knuth_1(1) := L(2)* R(2); - knuth_1(2) := (L(0) + L(1) + L(2)) * (R(0) + R(1) + R(2)); - knuth_1(3) := F_Left(2) * F_Right(2); - knuth_1(4) := F_Left(3) * F_Right(3); - knuth_1(5) := F_Left(4) * F_Right(4); - - knuth_2(1) := knuth_1(2) - knuth_1(1); - knuth_2(2) := knuth_1(3) - knuth_1(2); - knuth_2(3) := knuth_1(4) - knuth_1(3); - knuth_2(4) := knuth_1(5) - knuth_1(4); - knuth_3(1) := Shift_Right((knuth_2(2) - knuth_2(1)),1); - knuth_3(2) := Shift_Right((knuth_2(3) - knuth_2(2)),1); - knuth_3(3) := Shift_Right((knuth_2(4) - knuth_2(3)),1); - knuth_4(1) := (knuth_3(2) - knuth_3(1)) / 3; - knuth_4(2) := (knuth_3(3) - knuth_3(2)) / 3; - knuth_5_1 := Shift_Right(knuth_4(2) - knuth_4(1),2); - - Z(0) := knuth_5_1; - Z(1) := knuth_4(1); - Z(2) := knuth_3(1); - Z(3) := knuth_2(1); - Z(4) := knuth_1(1); - - -- RECOMPOSITION ............................................................ - - knuth_1(1) := Z(1) - (Z(0) + Shift_Left(Z(0),1)); - knuth_1(2) := knuth_1(1) - (Shift_Left(Z(0),1)); - knuth_1(3) := knuth_1(2) - Z(0); - knuth_2(1) := Z(2) - (Shift_Left(knuth_1(1),1)); - knuth_2(2) := knuth_2(1) - knuth_1(2); - knuth_3(1) := Z(3) - knuth_2(1); - - Result := Shift_Left( Z(0), DN*2) - + Shift_Left(knuth_1(3), DN+N) - + Shift_Left(knuth_2(2), DN) - + Shift_Left(knuth_3(1), N) - + Z(4); - end; - end if; - return Result; - end Toom_Cook; - --------------------------------------------------------------------------------- - - function Toom_Cook_P(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - begin - if Bit_Length(Left)+Bit_Length(Right) < Word'Size then - Result.Number(0) := Left.Number(0) * Right.Number(0); - else - declare - knuth_1 : Array (1..5) of Big_Unsigned; - knuth_2 : Array (1..4) of Big_Unsigned; - knuth_3 : Array (1..3) of Big_Unsigned; - knuth_4 : Array (1..2) of Big_Unsigned; - knuth_5_1 : Big_Unsigned; - L, R : Array (0..3) of Big_Unsigned; - F_Left, F_Right : Array (2..4) of Big_Unsigned; - Z : Array (0..4) of Big_Unsigned; - - Length : constant Natural := Natural'Max(Bit_Length(Left) , - Bit_Length(Right) ); - N : constant Natural := Length / 3; - DN : constant Natural := 2 * N; - - task type Toom_Cook_Task_Type is - entry Input (Left, Right : in Big_Unsigned); - entry Output(Result : out Big_Unsigned); - end Toom_Cook_Task_Type; - task body Toom_Cook_Task_Type is - X : Big_Unsigned; - Left_Local : Big_Unsigned; - Right_Local : Big_Unsigned; - begin - accept Input (Left, Right : Big_Unsigned) do - Left_Local := Left; - Right_Local := Right; - end Input; - - X := Left_Local * Right_Local; - - accept Output(Result : out Big_Unsigned) do - Result := X; - end Output; - end Toom_Cook_Task_Type; - - Task_1 : Toom_Cook_Task_Type; - Task_2 : Toom_Cook_Task_Type; - Task_3 : Toom_Cook_Task_Type; - Task_4 : Toom_Cook_Task_Type; - Task_5 : Toom_Cook_Task_Type; - - begin - -- SPLITTING ............................................................. - L(0) := Shift_Right( Left, DN); - L(1) := Shift_Right( Left, N ) - Shift_Left( L(0), N ); - L(2) := Left - Shift_Left( L(0), DN ) - Shift_Left( L(1), N ); - R(0) := Shift_Right( Right, DN); - R(1) := Shift_Right( Right, N ) - Shift_Left( R(0), N ); - R(2) := Right - Shift_Left( R(0), DN ) - Shift_Left( R(1), N ); - -- EVALUATION ............................................................ - F_Left(2) := Shift_Left(L(0),2) + Shift_Left(L(1),1) + L(2); - F_Right(2) := Shift_Left(R(0),2) + Shift_Left(R(1),1) + R(2); - F_Left(3) := (Shift_Left(L(0),3) + L(0)) - + (Shift_Left(L(1),1)+L(1)) + L(2); - F_Right(3) := (Shift_Left(R(0),3) + R(0)) - + (Shift_Left(R(1),1)+R(1)) + R(2); - F_Left(4) := Shift_Left(L(0),4) + Shift_Left(L(1),2) + L(2); - F_Right(4) := Shift_Left(R(0),4) + Shift_Left(R(1),2) + R(2); - -- INTERPOLATION with POINTWISE MULT ..................................... - Task_1.Input( L(2), R(2) ); - Task_2.Input(L(0) + L(1) + L(2), R(0) + R(1) + R(2)); - Task_3.Input(F_Left(2), F_Right(2)); - Task_4.Input(F_Left(3), F_Right(3)); - Task_5.Input(F_Left(4), F_Right(4)); - Task_1.Output(Result => knuth_1(1)); - Task_2.Output(Result => knuth_1(2)); - Task_3.Output(Result => knuth_1(3)); - Task_4.Output(Result => knuth_1(4)); - Task_5.Output(Result => knuth_1(5)); - - knuth_2(1) := knuth_1(2) - knuth_1(1); - knuth_2(2) := knuth_1(3) - knuth_1(2); - knuth_2(3) := knuth_1(4) - knuth_1(3); - knuth_2(4) := knuth_1(5) - knuth_1(4); - knuth_3(1) := Shift_Right((knuth_2(2) - knuth_2(1)),1); - knuth_3(2) := Shift_Right((knuth_2(3) - knuth_2(2)),1); - knuth_3(3) := Shift_Right((knuth_2(4) - knuth_2(3)),1); - knuth_4(1) := (knuth_3(2) - knuth_3(1)) / 3; - knuth_4(2) := (knuth_3(3) - knuth_3(2)) / 3; - knuth_5_1 := Shift_Right(knuth_4(2) - knuth_4(1),2); - - Z(0) := knuth_5_1; - Z(1) := knuth_4(1); - Z(2) := knuth_3(1); - Z(3) := knuth_2(1); - Z(4) := knuth_1(1); - -- RECOMPOSITION ......................................................... - knuth_1(1) := Z(1) - (Z(0) + Shift_Left(Z(0),1)); - knuth_1(2) := knuth_1(1) - (Shift_Left(Z(0),1)); - knuth_1(3) := knuth_1(2) - Z(0); - knuth_2(1) := Z(2) - (Shift_Left(knuth_1(1),1)); - knuth_2(2) := knuth_2(1) - knuth_1(2); - knuth_3(1) := Z(3) - knuth_2(1); - - Result := Shift_Left( Z(0), DN*2) - + Shift_Left(knuth_1(3), DN+N) - + Shift_Left(knuth_2(2), DN) - + Shift_Left(knuth_3(1), N) - + Z(4); - end; - end if; - return Result; - end Toom_Cook_P; - ---============================================================================-- - --------------------------------------------------------------------------- - - function "*"(Left : Big_Unsigned; Right : Word) return Big_Unsigned is - begin - if Right = 0 or Left = Big_Unsigned_Zero then return Big_Unsigned_Zero; - elsif Right = 1 then return Left; - end if; - - declare - Result : Big_Unsigned; - begin - for I in 0..Word'Size loop - if (Shift_Right(Right,I) mod 2) = 1 then - Result:= Result + Shift_Left(Left,I); - end if; - end loop; - return Result; - end; - end "*"; - - --------------------------------------------------------------------------- - - function "*"(Left : Word; Right : Big_Unsigned) return Big_Unsigned is - begin - return Right * Left; - end "*"; - - --------------------------------------------------------------------------- - - function "**"(Left, Right : Big_Unsigned) return Big_Unsigned is - begin - if Left = Big_Unsigned_Zero or Left = Big_Unsigned_One then - return Left; - end if; - - -- Square_And_Multiply - declare - Result : Big_Unsigned := Big_Unsigned_One; - begin - for I in reverse 0..Bit_Length(Right)-1 loop - Result := Result * Result; - if (Shift_Right(Right, I) mod 2) = Big_Unsigned_One then - Result := Result * Left; - end if; - end loop; - return Result; - end; - end "**"; - - --------------------------------------------------------------------------- - - - function "/"(Left, Right : Big_Unsigned) return Big_Unsigned is - Q : Big_Unsigned; - R : Big_Unsigned; - begin - Big_Div(Left,Right,Q,R); - return Q; - end "/"; - - --------------------------------------------------------------------------- - - function "/"(Left : Word; Right : Big_Unsigned) return Big_Unsigned is - Big_Left: constant Big_Unsigned := - (Last_Index => 0, Number => (0=> Left, others => 0)); - Q : Big_Unsigned; - R : Big_Unsigned; - begin - Big_Div(Big_Left,Right,Q,R); - return Q; - end "/"; - - --------------------------------------------------------------------------- - - function "/"(Left : Big_Unsigned; Right : Word) return Big_Unsigned is - Q : Big_Unsigned; - R : Word; - begin - Short_Div(Left,Right,Q,R); - return Q; - end "/"; - - - --------------------------------------------------------------------------- - - function "mod"(Left, Right : Big_Unsigned) return Big_Unsigned is - Q : Big_Unsigned; - R : Big_Unsigned; - begin - Big_Div(Left,Right,Q,R); - return R; - end "mod"; - - - - --------------------------------------------------------------------------- - - function "mod"(Left : Big_Unsigned; Right : Word) return Big_Unsigned is - Q : Big_Unsigned; - R : Word; - begin - Short_Div(Left,Right,Q,R); - declare - Result: constant Big_Unsigned := - (Last_Index => 0, Number => (0 => R, others => 0)); - begin - return Result; - end; - end "mod"; - - --------------------------------------------------------------------------- - - -- This is a helper function - -- This procedure computes/adjust the Last_Index of B - procedure Last_Index(B : in out Big_Unsigned; M : in M_Len:=Max_Length) is - begin - for I in reverse 0..M loop - if B.Number(I) /= 0 then - B.Last_Index := I; - exit; - end if; - end loop; - end Last_Index; pragma Inline (Last_Index); - - --------------------------------------------------------------------------- - - - function "xor"(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - M : constant Natural:= Natural'Max(Left.Last_Index, Right.Last_Index); - begin - -- xor - for I in 0..M loop - Result.Number(I) := Left.Number(I) xor Right.Number(I); - end loop; - - -- compute the Last_Index - Last_Index(Result,M); - - return Result; - - end "xor"; - - --------------------------------------------------------------------------- - - function "and"(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - M : constant Natural:= Natural'Min(Left.Last_Index, Right.Last_Index); - begin - - --and - for I in 0..M loop - Result.Number(I) := Left.Number(I) and Right.Number(I); - end loop; - - -- compute last index - Last_Index(Result, M); - - return Result; - end "and"; - - --------------------------------------------------------------------------- - - - function "and"(Left : Big_Unsigned; Right : Word) return Big_Unsigned - is - Result : Big_Unsigned; - begin - - Result.Number(0) := Left.Number(0) and Right; - - -- compute last index - Last_Index(Result, 0); - - return Result; - end "and"; - - --------------------------------------------------------------------------- - - function "and"(Left : Word; Right : Big_Unsigned) return Big_Unsigned - is - Result : Big_Unsigned; - begin - - Result.Number(0) := Left and Right.Number(0); - - -- compute last index - Last_Index(Result, 0); - - return Result; - end "and"; - - --------------------------------------------------------------------------- - - - function "or"(Left, Right : Big_Unsigned) return Big_Unsigned is - Result : Big_Unsigned; - M : constant Natural:= Natural'Max(Left.Last_Index, Right.Last_Index); - begin - -- or - for I in 0..M loop - Result.Number(I) := Left.Number(I) or Right.Number(I); - end loop; - - -- compute last index - Last_Index(Result, M); - - return Result; - end "or"; - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - -begin - if Size mod Word'Size /= 0 then - Put("Size must be a multiple of " & Word'Image(Word'Size)); - raise Constraint_Size_Error; - end if; -end Crypto.Types.Big_Numbers; diff --git a/src/crypto-types-big_numbers.ads b/src/crypto-types-big_numbers.ads deleted file mode 100644 index f75ad6b..0000000 --- a/src/crypto-types-big_numbers.ads +++ /dev/null @@ -1,399 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - --- With this packet you can generate (unsigned) n-Bit Numbers (Big_Unsigned). --- You can only create k*m Bit-Numbers where 1 < k < 2**32 and m is the --- size of a CPU-Word. For further informations read the ACL documentation. - --- The look and feel is "borrowed" from J. Delcourt BIG_NUMBER package. --- First I want to use Delcourts package directly, but then I decided to --- rewrite it completly form scratch. ;-) - -with System; - -with Crypto.Types; -use Crypto.Types; - -generic - Size : Positive; - -package Crypto.Types.Big_Numbers is - - type Big_Unsigned is private; - subtype Number_Base is Integer range 2 .. 16; - - -- Do not use this type. This one is only needed for internal purpose. - type D_Big_Unsigned is private; - - --------------------------------------------------------------------------- - ---------------------------Constants--------------------------------------- - --------------------------------------------------------------------------- - - -- A few constants - Big_Unsigned_Zero : constant Big_Unsigned; -- 0 - Big_Unsigned_One : constant Big_Unsigned; -- 1 - Big_Unsigned_Two : constant Big_Unsigned; -- 2 - Big_Unsigned_Three : constant Big_Unsigned; -- 3 - Big_Unsigned_Four : constant Big_Unsigned; -- 4 - Big_Unsigned_Ten : constant Big_Unsigned; -- 10 - Big_Unsigned_Sixteen : constant Big_Unsigned; -- 16 - Big_Unsigned_First : constant Big_Unsigned; -- 0 - Big_Unsigned_Last : constant Big_Unsigned; -- "Big_Unsigned'Last" - - --------------------------------------------------------------------------- - ----------------------------Compare---------------------------------------- - --------------------------------------------------------------------------- - - -- compare: Big Unsigned with Big_Unsigned - function "="(Left, Right : Big_Unsigned) return Boolean; - function "<"(Left, Right : Big_Unsigned) return Boolean; - function ">"(Left, Right : Big_Unsigned) return Boolean; - - function "<="(Left, Right : Big_Unsigned) return Boolean; - function ">="(Left, Right : Big_Unsigned) return Boolean; - - function Min(X, Y : in Big_Unsigned) return Big_Unsigned; - function Max(X, Y : in Big_Unsigned) return Big_Unsigned; - - -- compare: Big Unsigned with Word - function "="(Left : Big_Unsigned; Right : Word) return Boolean; - function "="(Left : Word; Right : Big_Unsigned) return Boolean; - - function "<"(Left : Big_Unsigned; Right : Word) return Boolean; - function "<"(Left : Word; Right : Big_Unsigned) return Boolean; - - function ">"(Left : Big_Unsigned; Right : Word) return Boolean; - function ">"(Left : Word; Right : Big_Unsigned) return Boolean; - - function "<="(Left : Big_Unsigned; Right : Word) return Boolean; - function "<="(Left : Word; Right : Big_Unsigned) return Boolean; - - function ">="(Left : Big_Unsigned; Right : Word) return Boolean; - function ">="(Left : Word; Right : Big_Unsigned) return Boolean; - - - --------------------------------------------------------------------------- - -----------------------------Basic----------------------------------------- - --------------------------------------------------------------------------- - - function "+"(Left, Right : Big_Unsigned) return Big_Unsigned; - function "+"(Left : Big_Unsigned; Right : Word) return Big_Unsigned; - function "+"(Left : Word; Right : Big_Unsigned) return Big_Unsigned; - - function "-"(Left, Right : Big_Unsigned) return Big_Unsigned; - function "-"(Left : Big_Unsigned; Right : Word) return Big_Unsigned; - function "-"(Left : Word; Right : Big_Unsigned) return Big_Unsigned; - - function "-"(X : Big_Unsigned) return Big_Unsigned; - - function "*"(Left, Right : Big_Unsigned) return Big_Unsigned; ---============================================================================-- - function Russ (Left, Right : Big_Unsigned) return Big_Unsigned; - function Karatsuba (Left, Right : Big_Unsigned) return Big_Unsigned; - function Karatsuba_P (Left, Right : Big_Unsigned) return Big_Unsigned; --- function Karatsuba_Prot (Left, Right : Big_Unsigned) return Big_Unsigned; - function Toom_Cook (Left, Right : Big_Unsigned) return Big_Unsigned; - function Toom_Cook_P (Left, Right : Big_Unsigned) return Big_Unsigned; ---============================================================================-- - function "*"(Left : Big_Unsigned; Right : Word) return Big_Unsigned; - function "*"(Left : Word; Right : Big_Unsigned) return Big_Unsigned; - - function "/"(Left, Right : Big_Unsigned) return Big_Unsigned; - function "/"(Left : Big_Unsigned; Right : Word) return Big_Unsigned; - function "/"(Left : Word; Right : Big_Unsigned) return Big_Unsigned; - - function "xor"(Left, Right : Big_Unsigned) return Big_Unsigned; - function "or" (Left, Right : Big_Unsigned) return Big_Unsigned; - - function "and"(Left, Right : Big_Unsigned) return Big_Unsigned; - function "and"(Left: Big_Unsigned; Right: Word) return Big_Unsigned; - function "and"(Left: Word; Right: Big_Unsigned) return Big_Unsigned; - - function "**"(Left, Right : Big_Unsigned) return Big_Unsigned; - - function "mod"(Left, Right : Big_Unsigned) return Big_Unsigned; - function "mod"(Left : Big_Unsigned; Right : Word) return Big_Unsigned; - - --------------------------------------------------------------------------- - ----------------------------Utils------------------------------------------ - --------------------------------------------------------------------------- - - package Utils is - - procedure Swap(X, Y : in out Big_Unsigned); - - procedure Set_Least_Significant_Bit(X : in out Big_Unsigned); - procedure Set_Most_Significant_Bit(X : in out Big_Unsigned); - - -- Returns true if X is odd . - function Is_Odd(X : Big_Unsigned) return Boolean; - - -- Returns true if X is even. - function Is_Even(X : Big_Unsigned) return Boolean; - - - -- Caution: All operations are mod Big_unsigned_Last+1. - -- X = Big_unsigned_Zero - -- Inc(X) - -- X = Big_Unsigned_Last - -- Dec(X) - -- X = Big_unsigned_Zero - procedure Inc(X : in out Big_Unsigned); - procedure Dec(X : in out Big_Unsigned); - - function To_Big_Unsigned(X : Word) return Big_Unsigned; - - - function Shift_Left(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned; - - function Shift_Right(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned; - - function Rotate_Left(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned; - - function Rotate_Right(Value : Big_Unsigned; Amount : Natural) - return Big_Unsigned; - - function Get_Random return Big_Unsigned; - - function Bit_Length(X : Big_Unsigned) return Natural; - - function Lowest_Set_Bit(X : Big_Unsigned) return Natural; - - function Length_In_Bytes(X : Big_Unsigned) return Natural; - - function Gcd(Left, Right : Big_Unsigned) return Big_Unsigned; - - function To_Bytes(X : Big_Unsigned) return Bytes; - - function To_Big_Unsigned(X : Bytes) return Big_Unsigned; - - function To_Words(X : Big_Unsigned) return Words; - - function To_Big_Unsigned(X : Words) return Big_Unsigned; - - function To_String(Item : Big_Unsigned; - Base : Number_Base := 10) return String; - - function To_Big_Unsigned(S : String) return Big_Unsigned; - - procedure Put(Item : in Big_Unsigned; Base : in Number_Base := 10); - - procedure Put_Line(Item : in Big_Unsigned; Base : in Number_Base := 10); - - - procedure Big_Div(Dividend, Divisor : in Big_Unsigned; - Quotient, Remainder : out Big_Unsigned); - - procedure Short_Div(Dividend : in Big_Unsigned; - Divisor : in Word; - Quotient : out Big_Unsigned; - Remainder : out Word); - end Utils; - - --------------------------------------------------------------------------- - --------------------------Mod_Utils---------------------------------------- - --------------------------------------------------------------------------- - - package Mod_Utils is - -- All operations in this package are mod N - - function Add (Left, Right, N : Big_Unsigned) return Big_Unsigned; - function Sub (Left, Right, N : Big_Unsigned) return Big_Unsigned; - function Div (Left, Right, N : Big_Unsigned) return Big_Unsigned; - function Mult(Left, Right, N : Big_Unsigned) return Big_Unsigned; --- function Barrett(Left, Right, M : Big_Unsigned) return Big_Unsigned; --- function Mult_School(Left, Right, N : Big_Unsigned) return Big_Unsigned; - - function Pow (Base, Exponent, N : Big_Unsigned) return Big_Unsigned; - - -- Returns a random Big_Unsigned mod N - function Get_Random (N : Big_Unsigned) return Big_Unsigned; - - function Inverse (X, N : Big_Unsigned) return Big_Unsigned; - - - -- This function returns with an overwhelming probability a prim - function Get_Prime(N : Big_Unsigned) return Big_Unsigned; - - -- This function returns with an overwhelming probability a n-bit prim - function Get_N_Bit_Prime(N : Positive) return Big_Unsigned; - - -- This function returns true if X is a prim and - -- with an overwhelming probability false if X is not prime - -- The change that a snowball survive one day in hell are greater that - -- this function returns true if X is no prim. - -- functionality: - -- 1. Test if a one digit prime (2,3,5,7) divides X - -- 2. Test if a two digit prime number divides X - -- 3. Test if X is a "Lucas-Lehmer" prime - -- 4. Test if a three digit prime number divides X - -- 5. compute N random Big_Unsigneds and test if one - -- of those is an Miller-Rabin wittness ( 1 < N < 51) - -- (N depends on the Bit_Length of X). - function Is_Prime(X : Big_Unsigned) return Boolean; - - - -- a weaker but faster prime test - function Looks_Like_A_Prime(X : Big_Unsigned) return Boolean; - - - -- Returns only true if X passed n iterations of the - -- Miller-Rabin tests. This test is taken from the DSA spec (NIST FIPS - -- 186-2).The execution time of this function is proportional - -- to the value of this parameter. - -- The probability that a pseudoprim pass this test is < (1/(2**(2*S))) - function Passed_Miller_Rabin_Test(X : Big_Unsigned; - S : Positive) return Boolean; - - function Jacobi(X, N : Big_Unsigned) return Integer; - - - -- internal functions for Binfield_Utils. Please, DON'T use them. - function Shift_Left(Value : D_Big_Unsigned; Amount : Natural) - return D_Big_Unsigned; - function Bit_Length(X : D_Big_Unsigned) return Natural; - end Mod_Utils; - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - - package Binfield_Utils is - - -- binary field operations - -- F is the irreducible polynom with f(z)=2^m + r(z) - -- Remember all operations are in GF(2^m) - - function B_Add(Left,Right : Big_Unsigned) return Big_Unsigned; - function B_Sub(Left,Right : Big_Unsigned) return Big_Unsigned; - - function B_Mult(Left, Right, F : Big_Unsigned) return Big_Unsigned; - function B_Div (Left, Right, F : Big_Unsigned) return Big_Unsigned; - - function B_Square(A, F : Big_Unsigned) return Big_Unsigned; - - function B_Mod(Left, Right : Big_Unsigned) return Big_Unsigned; - - function B_Inverse(X, F : Big_Unsigned) return Big_Unsigned; - - end Binfield_Utils; - - --------------------------------------------------------------------------- - -----------------------------Exceptions------------------------------------ - --------------------------------------------------------------------------- - - Constraint_Size_Error : exception; - Division_By_Zero : exception; - Conversion_Error : exception; - Is_Zero_Error : exception; - --- Big_Unsigned_Overflow : exception; --- Big_Unsigned_Negative : exception; - - --------------------------------------------------------------------------- - --------------------------------PRIVATE------------------------------------ - --------------------------------------------------------------------------- - -private - type Largest_Unsigned is mod System.Max_Binary_Modulus; - - Max_Length : Natural := (Size/Word'Size)-1; - D_Max_Length : Positive := 2*Max_Length+1; - - subtype Limbs is Words(0..Max_Length); - subtype DLimbs is Words(0..D_Max_Length); - - subtype M_Len is Natural range Limbs'Range; - - -- This is our Big_Unsigned - -- It represents a Size*Word'Size-bit number - -- Last_Index is the Number of the last slice who - -- contains the most significant bit of the current number. - -- Ex.: - -- Word'Size = 24 - -- Our Big_Unsigned A is equal to 2**100-7 - -- Big_Unsignesd_Last = 2**240-1 - -- So only Slice 0-4 contains a part of the current 99-Bit number (2**100-7) - -- In this case A.Last_Index = 4 because A.X(5)=...=A.X(9)=0 - - type Big_Unsigned is record - Last_Index : Natural:=0; - Number : Limbs:=(others => 0); - end record; - - type D_Big_Unsigned is record - Last_Index : Natural:=0; - Number : DLimbs:=(others => 0); - end record; - - -- prime test - type Hardness is (Weak, Strong); - - - -- Constants definitions - Big_Unsigned_Zero : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (OTHERS => 0)); - Big_Unsigned_One : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (0 => 1, OTHERS => 0)); - Big_Unsigned_Two : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (0 => 2, OTHERS => 0)); - Big_Unsigned_Three : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (0 => 3, OTHERS => 0)); - Big_Unsigned_Four : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (0 => 4, OTHERS => 0)); - Big_Unsigned_Ten : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (0 => 10, OTHERS => 0)); - Big_Unsigned_Sixteen : CONSTANT Big_Unsigned := - (Last_Index => 0, Number => (0 => 16, OTHERS => 0)); - Big_Unsigned_First : CONSTANT Big_Unsigned := - Big_Unsigned_Zero; - Big_Unsigned_Last : CONSTANT Big_Unsigned := - (Last_Index => Max_Length, Number => (OTHERS => Word'Last)); - - - D_Big_Unsigned_Zero : CONSTANT D_Big_Unsigned := - (Last_Index => 0, Number => (OTHERS => 0)); - D_Big_Unsigned_One : CONSTANT D_Big_Unsigned := - (Last_Index => 0, Number => (0 => 1, OTHERS => 0)); - D_Big_Unsigned_Last : CONSTANT D_Big_Unsigned := - (Last_Index => D_Max_Length, Number => (OTHERS => Word'Last)); - - -- Shifting - - function Shift_Left (Value : Largest_Unsigned; Amount : Natural) - return Largest_Unsigned; - function Shift_Right (Value : Largest_Unsigned; Amount : Natural) - return Largest_Unsigned; - - - - --pragma Inline("-", "/", "**", "mod", "xor", "and", "or"); - pragma Inline("=", "<", ">", "<=", ">=", Min, Max); - pragma Import (Intrinsic, Shift_Left); - pragma Import (Intrinsic, Shift_Right); - - pragma Optimize (Time); - -end Crypto.Types.Big_Numbers; diff --git a/src/crypto-types-random.adb b/src/crypto-types-random.adb deleted file mode 100644 index 4eb6aca..0000000 --- a/src/crypto-types-random.adb +++ /dev/null @@ -1,72 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. ---with Ada.Numerics.Discrete_Random; - -with Crypto; -with Crypto.Types.Random_Source.File; - -package body Crypto.Types.Random is - Dev_Random : Crypto.Types.Random_Source.File.Random_Source_File; - - Rnd_Src : aliased Crypto.Types.Random_Source.Random_Source'Class - := Crypto.Types.Random_Source.Random_Source'Class(Dev_Random); - - procedure Set(Source : in Crypto.Types.Random_Source.Random_Source'Class) is - begin - Rnd_Src := Source; - end Set; - - procedure Read(B : out Byte) is - begin - Rnd_Src.Read(B); - end Read; - - procedure Read(Byte_Array : out Bytes) is - begin - Rnd_Src.Read(Byte_Array); - end Read; - - procedure Read(B : out B_Block128) is - begin - Rnd_Src.Read(B); - end Read; - - procedure Read(W : out Word) is - begin - Rnd_Src.Read(W); - end Read; - - procedure Read(Word_Array : out Words) is - begin - Rnd_Src.Read(Word_Array); - end Read; - - procedure Read(D : out DWord) is - begin - Rnd_Src.Read(D); - end Read; - - procedure Read(DWord_Array : out DWords) is - begin - Rnd_Src.Read(DWord_Array); - end Read; -end Crypto.Types.Random; diff --git a/src/crypto-types-random.ads b/src/crypto-types-random.ads deleted file mode 100644 index a3e0b37..0000000 --- a/src/crypto-types-random.ads +++ /dev/null @@ -1,41 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - -with Crypto.Types.Random_Source; -use Crypto.Types; - -package Crypto.Types.Random is - procedure Set(Source : in Crypto.Types.Random_Source.Random_Source'Class); - - procedure Read(B : out Byte); - procedure Read(Byte_Array : out Bytes); - procedure Read(B : out B_Block128); - - procedure Read(W : out Word); - procedure Read(Word_Array : out Words); - - procedure Read(D : out DWord); - procedure Read(DWord_Array : out DWords); - - pragma Inline (Read); - pragma Optimize (Time); -end Crypto.Types.Random; diff --git a/src/crypto-types-random_source-file.adb b/src/crypto-types-random_source-file.adb deleted file mode 100644 index e665990..0000000 --- a/src/crypto-types-random_source-file.adb +++ /dev/null @@ -1,144 +0,0 @@ -package body Crypto.Types.Random_Source.File is - use Ada.Strings.Unbounded; - use Ada.Streams.Stream_IO; - - --------------------------------------------------------------------------- - ------------------------ Initialization ----------------------------------- - --------------------------------------------------------------------------- - - - procedure Initialize(This : in out Random_Source_File) is - Path : constant String := "/dev/random"; - Mode : constant File_Mode := In_File; - begin - if This.Source_File = null then - This.Source_File := new Ada.Streams.Stream_IO.File_Type; - end if; - if not Is_Open(This.Source_File.all) then - Open(This.Source_File.all, Mode, Path, "shared=yes"); - This.Source_Path := To_Unbounded_String(Path); - end if; - end Initialize; - - --------------------------------------------------------------------------- - - procedure Initialize(This : in out Random_Source_File; - File_Path : in String) is - Mode : constant File_Mode := In_File; - begin - if Is_Open(This.Source_File.all) then - Close(This.Source_File.all); - end if; - if not Is_Open(This.Source_File.all) then - Open(This.Source_File.all, Mode, File_Path, "shared=yes"); - This.Source_Path := To_Unbounded_String(File_Path); - end if; - end Initialize; - - --------------------------------------------------------------------------- - ------------------------------- Read Byte --------------------------------- - --------------------------------------------------------------------------- - - - procedure Read(This : in out Random_Source_File; B : out Byte) is - - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - Byte'Read(Stream(This.Source_File.all), B); - end if; - end Read; - - --------------------------------------------------------------------------- - - procedure Read(This : in out Random_Source_File; Byte_Array : out Bytes) is - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - Bytes'Read(Stream(This.Source_File.all), Byte_Array); - end if; - end Read; - - --------------------------------------------------------------------------- - - procedure Read(This : in out Random_Source_File; B : out B_Block128) is - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - B_Block128'Read(Stream(This.Source_File.all), B); - end if; - end Read; - - --------------------------------------------------------------------------- - ------------------------------- Read Word --------------------------------- - --------------------------------------------------------------------------- - - procedure Read(This : in out Random_Source_File; W : out Word) is - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - Word'Read(Stream(This.Source_File.all), W); - end if; - end Read; - - --------------------------------------------------------------------------- - - procedure Read(This : in out Random_Source_File; Word_Array : out Words) is - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - Words'Read(Stream(This.Source_File.all), Word_Array); - end if; - end Read; - - --------------------------------------------------------------------------- - ------------------------------- Read DWord -------------------------------- - --------------------------------------------------------------------------- - - - procedure Read(This : in out Random_Source_File; D : out DWord) is - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - DWord'Read(Stream(This.Source_File.all), D); - end if; - end Read; - - procedure Read(This : in out Random_Source_File; DWord_Array : out DWords) is - begin - if not Path_Starts_With(This, "/dev/") and then End_Of_File(This.Source_File.all) then - raise RANDOM_SOURCE_READ_ERROR with To_String(This.Source_Path); - else - DWords'Read(Stream(This.Source_File.all), DWord_Array); - end if; - end Read; - - - --------------------------------------------------------------------------- - ------------------------------- Finalize ---------------------------------- - --------------------------------------------------------------------------- - - procedure Finalize(This : in out Random_Source_File) is - begin - if Is_Open(This.Source_File.all) then - Close(This.Source_File.all); - end if; - end Finalize; - - --------------------------------------------------------------------------- - --------------------------- Path_Starts_With ------------------------------ - --------------------------------------------------------------------------- - - function Path_Starts_With(This : Random_Source_File; S : String) return Boolean is - Path : constant String := To_String(This.Source_Path); - begin - return Path(Path'First..S'Last) = S; - end; - -end Crypto.Types.Random_Source.File; diff --git a/src/crypto-types-random_source-file.ads b/src/crypto-types-random_source-file.ads deleted file mode 100644 index 8a3e960..0000000 --- a/src/crypto-types-random_source-file.ads +++ /dev/null @@ -1,50 +0,0 @@ -with Ada.Streams.Stream_IO; -with Ada.Strings.Unbounded; - -package Crypto.Types.Random_Source.File is - package Rnd renames Crypto.Types.Random_Source; - - type Random_Source_File is new Rnd.Random_Source with private; - type Random_Source_File_Access is access Random_Source_File; - - Overriding - procedure Finalize(This : in out Random_Source_File); - - Overriding - procedure Initialize(This : in out Random_Source_File); - - procedure Initialize(This : in out Random_Source_File; - File_Path : in String); - Overriding - procedure Read(This : in out Random_Source_File; B : out Byte); - - Overriding - procedure Read(This : in out Random_Source_File; Byte_Array : out Bytes); - - Overriding - procedure Read(This : in out Random_Source_File; B : out B_Block128); - - Overriding - procedure Read(This : in out Random_Source_File; W : out Word); - - Overriding - Procedure Read(This : in out Random_Source_File; Word_Array : out Words); - - Overriding - procedure Read(This : in out Random_Source_File; D : out DWord); - - Overriding - procedure Read(This : in out Random_Source_File; DWord_Array : out DWords); -private - type File_Access is access Ada.Streams.Stream_IO.File_Type; - - type Random_Source_File is new Rnd.Random_Source with - record - Source_Path : Ada.Strings.Unbounded.Unbounded_String; - Source_File : File_Access; - end record; - - function Path_Starts_With(This : Random_Source_File; S : String) - return Boolean; - -end Crypto.Types.Random_Source.File; diff --git a/src/crypto-types-random_source.adb b/src/crypto-types-random_source.adb deleted file mode 100644 index 5fd4dbb..0000000 --- a/src/crypto-types-random_source.adb +++ /dev/null @@ -1,55 +0,0 @@ -package body Crypto.Types.Random_Source is - - procedure Read(This : in out Random_Source; Byte_Array : out Bytes) is - begin - for I in Byte_Array'Range loop - Read(Random_Source'class(This),Byte_Array(I)); - end loop; - end Read; - - ---------------------------------------------------------------------- - - procedure Read(This : in out Random_Source; B : out B_Block128) is - begin - for I in B'Range loop - Read(Random_Source'class(This),B(I)); - end loop; - end Read; - - ---------------------------------------------------------------------- - - procedure Read(This : in out Random_Source; W : out Word) is - B : Byte_Word; - begin - This.Read(Bytes(B)); - W := To_Word(B); - end Read; - - ---------------------------------------------------------------------- - - procedure Read(This : in out Random_Source; Word_Array : out Words) is - begin - for I in Word_Array'Range loop - This.Read(Word_Array(I)); - end loop; - end Read; - - ---------------------------------------------------------------------- - - procedure Read(This : in out Random_Source; D : out DWord) is - B : Byte_DWord; - begin - This.Read(Bytes(B)); - D := To_DWord(B); - end Read; - - ---------------------------------------------------------------------- - - procedure Read(This : in out Random_Source; DWord_Array : out DWords) is - begin - for I in DWord_Array'Range loop - This.Read(DWord_Array(I)); - end loop; - end Read; - -end Crypto.Types.Random_Source; diff --git a/src/crypto-types-random_source.ads b/src/crypto-types-random_source.ads deleted file mode 100644 index 9ad55f6..0000000 --- a/src/crypto-types-random_source.ads +++ /dev/null @@ -1,27 +0,0 @@ -with Ada.Finalization; - -package Crypto.Types.Random_Source is - use Crypto.Types; - package Fin renames Ada.Finalization; - - type Random_Source is abstract new Fin.Controlled with null record; - type Random_Source_Access is access Random_Source; - - Random_Source_Read_Error : exception; - - procedure Initialize (This: in out Random_Source) is abstract; - - procedure Read(This : in out Random_Source; B : out Byte) is abstract; - - procedure Read(This : in out Random_Source; Byte_Array : out Bytes); - - procedure Read(This : in out Random_Source; B : out B_Block128); - - procedure Read(This : in out Random_Source; W : out Word); - procedure Read(This : in out Random_Source; Word_Array : out Words); - - procedure Read(This : in out Random_Source; D : out DWord); - procedure Read(This : in out Random_Source; DWord_Array : out DWords); - - pragma Inline(Read); -end Crypto.Types.Random_Source; diff --git a/src/crypto-types.adb b/src/crypto-types.adb deleted file mode 100644 index ac9afc2..0000000 --- a/src/crypto-types.adb +++ /dev/null @@ -1,944 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - -with Ada.Unchecked_Conversion; - ---pragma Elaborate_All(Generic_Mod_Aux); - -package body Crypto.Types is - - package body Generic_Mod_Aux is - function "xor"(Left, Right : T_A) return T_A is - Result : T_A(0..Left'Length-1); - begin - if Left'Length /= Right'Length then - raise Constraint_Error; - end if; - for I in 0..Left'Length-1 loop - Result(I) := Left(Left'First+I) xor Right(Right'First+I); - end loop; - return Result; - end "xor"; - - ------------------------------------------------------------------------ - - function "xor"(Left : T_A; Right : T) return T_A is - Result : T_A := Left; - begin - Result(Result'Last) := Left(Result'Last) xor Right; - return Result; - end "xor"; - - ------------------------------------------------------------------------ - - function "xor"(Left : T; Right : T_A) return T_A is - begin - return Right xor Left; - end "xor"; - - - ------------------------------------------------------------------------ - - function "and"(Left, Right : T_A) return T_A is - Result : T_A(0..Left'Length-1); - begin - - if Left'Length /= Right'Length then - raise Constraint_Error; - end if; - for I in 0..Left'Length-1 loop - Result(I) := Left(Left'First+I) and Right(Right'First+I); - end loop; - return Result; - end "and"; - - ------------------------------------------------------------------------ - function "+"(Left : T_A; Right : T) return T_A is - Result: T_A(Left'Range) := Left; - begin - Result(Left'Last) := Left(Left'Last) + Right; - - -- overflow? - if Result(Left'Last) < Left(Left'Last) then - for I in reverse Left'First..Left'Last-1 loop - Result(I):=Result(I)+1; - if Result(I) /= 0 then - return Result; - end if; - end loop; - end if; - return Result; - end "+"; - - - ------------------------------------------------------------------------ - function "+"(Left : T; Right : T_A) return T_A is - begin - return Right + Left; - end "+"; - ------------------------------------------------------------------------ - - function Is_Zero(Item : T_A) return Boolean is - begin - for I in Item'Range loop - if Item(I) /= 0 then return False; - end if; - end loop; - return True; - end Is_Zero; - ------------------------------------------------------------------------- - - function Left_Part(Block : in T_A) return T_A is - Len : constant Natural := ((Block'Length+1)/2)-1; - Left : constant T_A(0..Len) := Block(Block'First..(Block'First+Len)); - begin - return Left; - end Left_Part; - - ------------------------------------------------------------------------ - - function Right_Part(Block : in T_A) return T_A is - Len : constant Natural := Block'Length/2; - Right : constant T_A(0..Len-1) := Block(Block'Last-Len+1..Block'Last); - begin - return Right; - end Right_Part; - - ------------------------------------------------------------------------ - - function Shift_Left(Value : T_A; Amount : Natural) return T_A is - Result : T_A(Value'Range) := (others => 0); - L : constant Natural := Amount mod T'Size; - M : constant Natural := Value'First+(Amount/T'Size); - begin - if Amount >= Value'Size then - return Result; - elsif Amount = 0 then - return Value; - end if; - Result(Value'Last-M) := Shift_Left(Value(Value'Last),L); - - for I in reverse Value'First..Value'Last-(M+1) loop - Result(I) := Shift_Left(Value(I),L) - xor Shift_Right(Value(I+1),T'Size-L); - end loop; - return Result; - end Shift_Left; - ------------------------------------------------------------------------- - function Shift_Right(Value : T_A; Amount : Natural) return T_A is - Result : T_A(Value'Range) := (others => 0); - L : constant Natural := Amount mod T'Size; - M : constant Natural := Value'First+(Amount/T'Size); - begin - if Amount >= Value'Size then - return Result; - elsif Amount = 0 then - return Value; - end if; - Result(Value'Last-M) := Shift_Right(Value(Value'Last),L); - - for I in reverse Value'First..Value'Last-(M+1) loop - Result(I) := Shift_Right(Value(I),L) - xor Shift_Left(Value(I+1),T'Size-L); - end loop; - return Result; - end Shift_Right; - - end Generic_Mod_Aux; - - - function Cast is new Ada.Unchecked_Conversion (Byte_Word, Word); - function Cast is new Ada.Unchecked_Conversion (Word, Byte_Word); - function DCast is new Ada.Unchecked_Conversion (Byte_DWord, DWord); - function DCast is new Ada.Unchecked_Conversion (DWord, Byte_DWord); - pragma Inline (Cast, DCast); - - - package Aux_Byte is new Generic_Mod_Aux(Byte,Bytes); - package Aux_Word is new Generic_Mod_Aux(Word,Words); - package Aux_DWord is new Generic_Mod_Aux(Dword,DWords); - - --------------------------------------------------------------------------- - - function To_Word(A,B,C,D : Character) return Word is - begin - return Cast((Byte(Character'Pos(D)), Byte(Character'Pos(C)), - Byte(Character'Pos(B)), Byte(Character'Pos(A)))); - end To_Word; - - --------------------------------------------------------------------------- - - function To_Word(A,B,C,D : Byte) return Word is - begin - return Cast((D, C, B, A)); - end To_Word; - - --------------------------------------------------------------------------- - - function To_Word (X : Byte_Word) return Word is - begin - return Cast((X(3), X(2), X(1), X(0))); - end To_Word; - - --------------------------------------------------------------------------- - - function R_To_Word (X : Byte_Word) return Word is - begin - return Cast(X); - end R_To_Word; - - --------------------------------------------------------------------------- - - function To_Bytes (X : Word) return Byte_Word is - begin - return (Cast(X)(3), Cast(X)(2), Cast(X)(1), Cast(X)(0)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function R_To_Bytes (X : Word) return Byte_Word is - begin - return Cast(X); - end R_To_Bytes; - - --------------------------------------------------------------------------- - - function Byte0 (W : Word) return Byte is - begin - return Cast(W)(3); - end Byte0; - - --------------------------------------------------------------------------- - - function Byte1 (W : Word) return Byte is - begin - return Cast(W)(2); - end Byte1; - - --------------------------------------------------------------------------- - - function Byte2 (W : Word) return Byte is - begin - return Cast(W)(1); - end Byte2; - - --------------------------------------------------------------------------- - - function Byte3 (W : Word) return Byte is - begin - return Cast(W)(0); - end Byte3; - - --------------------------------------------------------------------------- - - function To_DWord (X : Byte_DWord) return DWord is - begin - return DCast((X(7), X(6), X(5), X(4), X(3), X(2), X(1), X(0))); - end To_DWord; - - --------------------------------------------------------------------------- - - function R_To_DWord (X : Byte_DWord) return DWord is - begin - return DCast(X); - end R_To_DWord; - - --------------------------------------------------------------------------- - - function To_Bytes (X : DWord) return Byte_DWord is - begin - return (DCast(X)(7), DCast(X)(6), DCast(X)(5), DCast(X)(4), - DCast(X)(3), DCast(X)(2), DCast(X)(1), DCast(X)(0)); - - end To_Bytes; - - --------------------------------------------------------------------------- - - function R_To_Bytes (X : DWord) return Byte_DWord is - begin - return DCast(X); - end R_To_Bytes; - - --------------------------------------------------------------------------- - - function Byte0 (D : DWord) return Byte is - begin - return DCast(D)(7); - end Byte0; - - --------------------------------------------------------------------------- - function Byte1 (D : DWord) return Byte is - begin - return DCast(D)(6); - end Byte1; - - --------------------------------------------------------------------------- - - function Byte2 (D : DWord) return Byte is - begin - return DCast(D)(5); - end Byte2; - - --------------------------------------------------------------------------- - - function Byte3 (D : DWord) return Byte is - begin - return DCast(D)(4); - end Byte3; - - --------------------------------------------------------------------------- - - function Byte4 (D : DWord) return Byte is - begin - return DCast(D)(3); - end Byte4; - - --------------------------------------------------------------------------- - - function Byte5 (D : DWord) return Byte is - begin - return DCast(D)(2); - end Byte5; - - --------------------------------------------------------------------------- - - function Byte6 (D : DWord) return Byte is - begin - return DCast(D)(1); - end Byte6; - - --------------------------------------------------------------------------- - - function Byte7 (D : DWord) return Byte is - begin - return DCast(D)(0); - end Byte7; - - --------------------------------------------------------------------------- - - - function "xor"(Left, Right : Bytes) return Bytes is - begin - return Aux_Byte."xor"(Left,Right); - end "xor"; - - --------------------------------------------------------------------------- - - function "xor"(Left : Bytes; Right : Byte) return Bytes is - begin - return Aux_Byte."xor"(Left,Right); - end "xor"; - - --------------------------------------------------------------------------- - - function "+"(Left : Bytes; Right : Byte) return Bytes is - begin - return Aux_Byte."+"(Left,Right); - end "+"; - - --------------------------------------------------------------------------- - - function "+"(Left : Byte; Right : Bytes) return Bytes is - begin - return Right + Left; - end "+"; - - --------------------------------------------------------------------------- - - function "and"(Left, Right : Bytes) return Bytes is - begin - return Aux_Byte."and"(Left,Right); - end "and"; - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - - function "xor"(Left, Right : Words) return Words is - begin - return Aux_Word."xor"(Left,Right); - end "xor"; - - --------------------------------------------------------------------------- - - function "+"(Left : Words; Right : Word) return Words is - - begin - return Aux_Word."+"(Left,Right); - end "+"; - - --------------------------------------------------------------------------- - - function "+"(Left : Word; Right : Words) return Words is - begin - return Right + Left; - end "+"; - - --------------------------------------------------------------------------- - - function "+"(Left : Words; Right : Byte) return Words is - Result: Words(Left'Range) := Left; - begin - Result(Left'Last) := Left(Left'Last) + Word(Right); - - -- overflow? - if Result(Left'Last) < Left(Left'Last) then - for I in reverse Left'First..Left'Last-1 loop - Result(I):=Result(I)+1; - if Result(I) /= 0 then - return Result; - end if; - end loop; - end if; - return Result; - end "+"; - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - - function "xor"(Left, Right : DWords) return DWords is - begin - return Aux_DWord."xor"(Left,Right); - end "xor"; - - --------------------------------------------------------------------------- - - function "+"(Left : DWords; Right : DWord) return DWords is - begin - return Aux_DWord."+"(Left,Right); - end "+"; - - --------------------------------------------------------------------------- - - function "+"(Left : DWord; Right : DWords) return DWords is - begin - return Right + Left; - end "+"; - - --------------------------------------------------------------------------- - - function "+"(Left : DWords; Right : Byte) return DWords is - Result: DWords(Left'Range) := Left; - begin - Result(Left'Last) := Left(Left'Last) + DWord(Right); - - -- overflow? - if Result(Left'Last) < Left(Left'Last) then - for I in reverse Left'First..Left'Last-1 loop - Result(I):=Result(I)+1; - if Result(I) /= 0 then - return Result; - end if; - end loop; - end if; - return Result; - end "+"; - - --------------------------------------------------------------------------- - - function To_Words(Byte_Array : Bytes) return Words is - L : constant Natural := - Natural(Float'Ceiling(Float(Byte_Array'Length)/4.0))-1; - W : Words(0..L) := (others => 0); - N : Integer := Byte_Array'First; - S : Natural :=24; - begin - - for I in 0..(Byte_Array'Length/4)-1 loop - W(I) := To_Word(Byte_Array(N..N+3)); - N := N+4; - end loop; - - for I in 1..(Byte_Array'Length mod 4) loop - W(L):= W(L) or Shift_Left(Word(Byte_Array(N)),S); - N := N+1; - S := S-8; - end loop; - - return W; - end To_Words; - - --------------------------------------------------------------------------- - - function To_Bytes(Word_Array : Words) return Bytes is - B : Bytes(1..Word_Array'Length*4); - C : Natural := 1; - begin - for I in Word_Array'Range loop - B(C..C+3) := To_Bytes(Word_Array(I)); - C:=C+4; - end loop; - return B; - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_DWords(Byte_Array : Bytes) return DWords is - L : constant Natural := - Natural(Float'Ceiling(Float(Byte_Array'Length)/8.0))-1; - W : DWords(0..L):=(others => 0); - N : Natural := Byte_Array'First; - S : Natural := 56; - begin - - for I in 0..(Byte_Array'Length/8)-1 loop - W(I) := To_DWord(Byte_Array(N..N+7)); - N := N+8; - end loop; - - for I in 1..(Byte_Array'Length mod 8) loop - W(L):= W(L) or Shift_Left(DWord(Byte_Array(N)),S); - N := N+1; - S := S-8; - end loop; - - return W; - end To_DWords; - - --------------------------------------------------------------------------- - - - function To_Bytes(DWord_Array : DWords) return Bytes is - B : Bytes(1..DWord_Array'Length*8); - C : Natural := 1; - begin - for I in DWord_Array'Range loop - B(C..C+7) := To_Bytes(DWord_Array(I)); - C:=C+8; - end loop; - return B; - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Hex(B : Byte) return Hex_Byte is - S : constant String := "0123456789ABCDEF"; - H : Hex_Byte; - begin - H(2) := S(Natural(B and 15)+1); - H(1) := S(Natural(Shift_Right(B,4)+1)); - return H; - end To_Hex; - - --------------------------------------------------------------------------- - - function To_Hex(W : Word) return Hex_Word is - S : constant String := "0123456789ABCDEF"; - H : Hex_Word; - T : Word := W; - begin - for I in reverse H'Range loop - H(I) := S(Natural(T and 15)+1); - T := Shift_Right(T,4); - end loop; - return H; - end To_Hex; - - --------------------------------------------------------------------------- - - - function To_Hex(D : DWord) return Hex_DWord is - S : constant String := "0123456789ABCDEF"; - H : Hex_DWord; - T : DWord := D; - begin - for I in reverse H'Range loop - H(I) := S(Natural(T and 15)+1); - T := Shift_Right(T,4); - end loop; - - return H; - end To_Hex; - - - function Hex_To_Bytes(Hex : String) return Bytes is - Return_Bytes : Bytes(0..Hex'Length/2 -1); - begin - for I in Return_Bytes'Range loop - case Hex(Hex'First + 2*i) is - when '0' => Return_Bytes(i):=16#00#; - when '1' => Return_Bytes(i):=16#01#; - when '2' => Return_Bytes(i):=16#02#; - when '3' => Return_Bytes(i):=16#03#; - when '4' => Return_Bytes(i):=16#04#; - when '5' => Return_Bytes(i):=16#05#; - when '6' => Return_Bytes(i):=16#06#; - when '7' => Return_Bytes(i):=16#07#; - when '8' => Return_Bytes(i):=16#08#; - when '9' => Return_Bytes(i):=16#09#; - when 'A' => Return_Bytes(i):=16#0A#; - when 'B' => Return_Bytes(i):=16#0B#; - when 'C' => Return_Bytes(i):=16#0C#; - when 'D' => Return_Bytes(i):=16#0D#; - when 'E' => Return_Bytes(i):=16#0E#; - when 'F' => Return_Bytes(i):=16#0F#; - when others => null; - end case; - - case Hex(Hex'First + 2*i + 1) is - when '0' => Return_Bytes(i):= Return_Bytes(i) + 16#00#; - when '1' => Return_Bytes(i):= Return_Bytes(i) + 16#10#; - when '2' => Return_Bytes(i):= Return_Bytes(i) + 16#20#; - when '3' => Return_Bytes(i):= Return_Bytes(i) + 16#30#; - when '4' => Return_Bytes(i):= Return_Bytes(i) + 16#40#; - when '5' => Return_Bytes(i):= Return_Bytes(i) + 16#50#; - when '6' => Return_Bytes(i):= Return_Bytes(i) + 16#60#; - when '7' => Return_Bytes(i):= Return_Bytes(i) + 16#70#; - when '8' => Return_Bytes(i):= Return_Bytes(i) + 16#80#; - when '9' => Return_Bytes(i):= Return_Bytes(i) + 16#90#; - when 'A' => Return_Bytes(i):= Return_Bytes(i) + 16#A0#; - when 'B' => Return_Bytes(i):= Return_Bytes(i) + 16#B0#; - when 'C' => Return_Bytes(i):= Return_Bytes(i) + 16#C0#; - when 'D' => Return_Bytes(i):= Return_Bytes(i) + 16#D0#; - when 'E' => Return_Bytes(i):= Return_Bytes(i) + 16#E0#; - when 'F' => Return_Bytes(i):= Return_Bytes(i) + 16#F0#; - when others => null; - end case; - - end loop; - return Return_Bytes; - end Hex_To_Bytes; - - --------------------------------------------------------------------------- - - function Is_Zero(Byte_Array : Bytes) return Boolean is - begin - return Aux_Byte.Is_Zero(Byte_Array); - end Is_Zero; - - --------------------------------------------------------------------------- - - - function Is_Zero(Word_Array : Words) return Boolean is - begin - return Aux_Word.Is_Zero(Word_Array); - end Is_Zero; - - --------------------------------------------------------------------------- - - function Is_Zero(DWord_Array : Dwords) return Boolean is - begin - return Aux_DWord.Is_Zero(DWord_Array); - end Is_Zero; - - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - --------------------------------------------------------------------------- - - function To_Bytes(Message : String) return Bytes is - B : Bytes(Message'Range); - begin - for I in Message'Range loop - B(I) := Character'Pos(Message(I)); - end loop; - return B; - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_String(ASCII : Bytes) return String is - S : String(1..ASCII'Length); - J : Integer:=1; - begin - for I in ASCII'Range loop - S(J) := Character'Val(ASCII(I)); - J:=J+1; - end loop; - return S; - end To_String; - - --------------------------------------------------------------------------- - - function Left_Part(Block : in Bytes) return Bytes is - begin - return Aux_Byte.Left_Part(Block); - end Left_Part; - - --------------------------------------------------------------------------- - - function Right_Part(Block : in Bytes) return Bytes is - begin - return Aux_Byte.Right_Part(Block); - end Right_Part; - - --------------------------------------------------------------------------- - - function To_Bytes(B : B_Block64) return Bytes is - begin - return Bytes(B); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(B : B_Block128) return Bytes is - begin - return Bytes(B); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(B : B_Block192) return Bytes is - - begin - return Bytes(B); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(B : B_Block256) return Bytes is - begin - return Bytes(B); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(W : W_Block160) return Bytes is - begin - return To_Bytes(Words(W)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(W : W_Block256) return Bytes is - begin - return To_Bytes(Words(W)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(W : W_Block512) return Bytes is - begin - return To_Bytes(Words(W)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(D : DW_Block256) return Bytes is - begin - return To_Bytes(DWords(D)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(D : DW_Block384) return Bytes is - begin - return To_Bytes(DWords(D)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(D : DW_Block512) return Bytes is - begin - return To_Bytes(DWords(D)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(D : DW_Block1024) return Bytes is - begin - return To_Bytes(DWords(D)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_Bytes(D : DW_Block8192) return Bytes is - begin - return To_Bytes(DWords(D)); - end To_Bytes; - - --------------------------------------------------------------------------- - - function To_B_Block64(B : Bytes) return B_Block64 is - begin - return B_Block64(B); - end To_B_Block64; - - --------------------------------------------------------------------------- - - function To_B_Block128(B : Bytes) return B_Block128 is - begin - return B_Block128(B); - end To_B_Block128; - - --------------------------------------------------------------------------- - - function To_B_Block192(B : Bytes) return B_Block192 is - begin - return B_Block192(B); - end To_B_Block192; - - --------------------------------------------------------------------------- - - function To_B_Block256(B : Bytes) return B_Block256 is - begin - return B_Block256(B); - end To_B_Block256; - - --------------------------------------------------------------------------- - - function To_W_Block160(B : Bytes) return W_Block160 is - begin - return W_Block160(To_Words(B)); - end To_W_Block160; - - --------------------------------------------------------------------------- - - function To_W_Block256(B : Bytes) return W_Block256 is - begin - return W_Block256(To_Words(B)); - end To_W_Block256; - - --------------------------------------------------------------------------- - - function To_W_Block512(B : Bytes) return W_Block512 is - begin - return W_Block512(To_Words(B)); - end To_W_Block512; - - --------------------------------------------------------------------------- - - function To_DW_Block256(B : Bytes) return DW_Block256 is - begin - return DW_Block256(To_DWords(B)); - end To_DW_Block256; - - --------------------------------------------------------------------------- - - function To_DW_Block384(B : Bytes) return DW_Block384 is - begin - return DW_Block384(To_DWords(B)); - end To_DW_Block384; - - --------------------------------------------------------------------------- - - function To_DW_Block512(B : Bytes) return DW_Block512 is - begin - return DW_Block512(To_DWords(B)); - end To_DW_Block512; - - --------------------------------------------------------------------------- - - function To_DW_Block1024(B : Bytes) return DW_Block1024 is - begin - return DW_Block1024(To_DWords(B)); - end To_DW_Block1024; - - --------------------------------------------------------------------------- - - function To_DW_Block8192(B : Bytes) return DW_Block8192 is - begin - return DW_Block8192(To_DWords(B)); - end To_DW_Block8192; - - --------------------------------------------------------------------------- - - function "xor"(Left, Right : W_Block160) return W_Block160 is - begin - return W_Block160(Words(Left) xor Words(Right)); - end "xor"; - --------------------------------------------------------------------------- - - function "xor"(Left, Right : W_Block256) return W_Block256 is - begin - return W_Block256(Words(Left) xor Words(Right)); - end "xor"; - --------------------------------------------------------------------------- - - function "xor"(Left, Right : W_Block512) return W_Block512 is - begin - return W_Block512(Words(Left) xor Words(Right)); - end "xor"; - - --------------------------------------------------------------------------- - - function "xor"(Left, Right : DW_Block512) return DW_Block512 is - begin - return DW_Block512(DWords(Left) xor DWords(Right)); - end "xor"; - - --------------------------------------------------------------------------- - - function "xor"(Left, Right : DW_Block1024) return DW_Block1024 is - begin - return DW_Block1024(DWords(Left) xor DWords(Right)); - end "xor"; - - --------------------------------------------------------------------------- - - function "xor"(Left, Right : DW_Block8192) return DW_Block8192 is - begin - return DW_Block8192(DWords(Left) xor DWords(Right)); - end "xor"; - - --------------------------------------------------------------------------- - - function "xor"(Left, Right : B_Block128) return B_Block128 is - begin - return B_Block128(Bytes(Left) xor Bytes(Right)); - end "xor"; - - --------------------------------------------------------------------------- - - function "xor"(Left, Right : B_Block64) return B_Block64 is - begin - return B_Block64(Bytes(Left) xor Bytes(Right)); - end "xor"; - - --------------------------------------------------------------------------- - - function "+"(Left : B_Block128; Right : Byte) return B_Block128 is - begin - return B_Block128(Bytes(Left) + Right); - end "+"; - - --------------------------------------------------------------------------- - - function Shift_Left(Value : Bytes; Amount : Natural) return Bytes is - begin - return Aux_Byte.Shift_Left(Value,Amount); - end Shift_Left; - - --------------------------------------------------------------------------- - - function Shift_Left(Value : B_Block128; Amount :Natural) return B_Block128 is - begin - return B_Block128(Aux_Byte.Shift_Left(Bytes(Value),Amount)); - end Shift_Left; - - ---------------------------------------------------------------------------- - - function Shift_Right(Value : Bytes; Amount : Natural) return Bytes is - begin - return Aux_Byte.Shift_Right(Value,Amount); - end Shift_Right; - - --------------------------------------------------------------------------- - - function Shift_Right(Value : B_Block128; Amount :Natural)return B_Block128 is - begin - return B_Block128(Aux_Byte.Shift_Right(Bytes(Value),Amount)); - end Shift_Right; - - - - - end Crypto.Types; diff --git a/src/crypto-types.ads b/src/crypto-types.ads deleted file mode 100644 index ebcd6dc..0000000 --- a/src/crypto-types.ads +++ /dev/null @@ -1,357 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - -package Crypto.Types is - - --------------------------------------------------------------------------- - ---------------------------TYPES------------------------------------------- - --------------------------------------------------------------------------- - - -- primary types; - - type Bit is mod 2; - for Bit'Size use 1; - - type Byte is mod 2 ** 8; - for Byte'Size use 8; - - type DByte is mod 2 ** 16; - for DByte'Size use 16; - - type TByte is mod 2 ** 24 with Size => 24; - - type Word is mod 2 ** 32; - for Word'Size use 32; - - type DWord is mod 2 ** 64; - for DWord'Size use 64; - - --package BIO is new Ada.Text_Io.Modular_IO (Byte); - --package WIO is new Ada.Text_Io.Modular_IO (Word); - --package DIO is new Ada.Text_Io.Modular_IO (DWord); - - -- Arrays of primary types - type Bits is array (Integer range <>) of Bit; - type Bytes is array (Integer range <>) of Byte; - type DBytes is array (Integer range <>) of DByte; - type Words is array (Integer range <>) of Word; - type DWords is array (Integer range <>) of DWord; - - subtype Byte_Word_Range is Natural range 0..3; - subtype Byte_DWord_Range is Natural range 0..7; - - subtype Byte_Word is Bytes (Byte_Word_Range); - subtype Byte_DWord is Bytes (Byte_DWord_Range); - - -- N : #bits - -- byte-blocks (B_BlockN): array of N/8 bytes - subtype B_Block32_Range is Natural range 0..3; - subtype B_Block48_Range is Natural range 0..5; - subtype B_Block56_Range is Natural range 0..6; - subtype B_Block64_Range is Natural range 0..7; - subtype B_Block128_Range is Natural range 0..15; - subtype B_Block160_Range is Natural range 0..19; - subtype B_Block192_Range is Natural range 0..23; - subtype B_Block256_Range is Natural range 0..31; - - type B_Block32 is array(B_Block32_Range) of Byte; - type B_Block48 is array(B_Block48_Range) of Byte; - type B_Block56 is array(B_Block56_Range) of Byte; - type B_Block64 is array(B_Block64_Range) of Byte; - type B_Block128 is array(B_Block128_Range) of Byte; - type B_Block160 is array(B_Block160_Range) of Byte; - type B_Block192 is array(B_Block192_Range) of Byte; - type B_Block256 is array(B_Block256_Range) of Byte; - - - -- word blocks (W_BlockN): array of N/32 Words - subtype W_Block128_Range is Natural range 0..3; - subtype W_Block160_Range is Natural range 0..4; - subtype W_Block192_Range is Natural range 0..5; - subtype W_Block256_Range is Natural range 0..7; - subtype W_Block512_Range is Natural range 0..15; - - type W_Block128 is array(W_Block128_Range) of Word; - type W_Block160 is array(W_Block160_Range) of Word; - type W_Block192 is array(W_Block192_Range) of Word; - type W_Block256 is array(W_Block256_Range) of Word; - type W_Block512 is array(W_Block512_Range) of Word; - - - -- double wordblocks (DW_BlockN): array of N/64 Words - subtype DW_Block128_Range is Natural range 0..1; - subtype DW_Block256_Range is Natural range 0..3; - subtype DW_Block384_Range is Natural range 0..5; - subtype DW_Block512_Range is Natural range 0..7; - subtype DW_Block1024_Range is Natural range 0..15; - subtype DW_Block8192_Range is Natural range 0..127; - - type DW_Block128 is array(DW_Block128_Range) of DWord; - type DW_Block256 is array(DW_Block256_Range) of DWord; - type DW_Block384 is array(DW_Block384_Range) of DWord; - type DW_Block512 is array(DW_Block512_Range) of DWord; - type DW_Block1024 is array(DW_Block1024_Range) of DWord; - type DW_Block8192 is array(DW_Block8192_Range) of DWord; - - - subtype Hex_Byte_Range is Natural range 1..2; - subtype Hex_Word_Range is Natural range 1..8; - subtype Hex_DWord_Range is Natural range 1..16; - - - subtype Hex_Byte is String (Hex_Byte_Range); - subtype Hex_Word is String (Hex_Word_Range); - subtype Hex_DWord is String (Hex_DWord_Range); - - subtype Message_Block_Length256 is Natural range 0 .. 32; - subtype Message_Block_Length512 is Natural range 0 .. 64; - subtype Message_Block_Length1024 is Natural range 0 .. 128; - - - - - - - - --------------------------------------------------------------------------- - ---------------------------FUNCTIONS--------------------------------------- - --------------------------------------------------------------------------- - - function Shift_Left (Value : Byte; Amount : Natural) return Byte; - function Shift_Right (Value : Byte; Amount : Natural) return Byte; - function Rotate_Left (Value : Byte; Amount : Natural) return Byte; - function Rotate_Right (Value : Byte; Amount : Natural) return Byte; - - function Shift_Left (Value : DByte; Amount : Natural) return DByte; - function Shift_Right (Value : DByte; Amount : Natural) return DByte; - function Rotate_Left (Value : DByte; Amount : Natural) return DByte; - function Rotate_Right (Value : DByte; Amount : Natural) return DByte; - - function Shift_Left (Value : Word; Amount : Natural) return Word; - function Shift_Right (Value : Word; Amount : Natural) return Word; - function Rotate_Left (Value : Word; Amount : Natural) return Word; - function Rotate_Right (Value : Word; Amount : Natural) return Word; - - function Shift_Left (Value : DWord; Amount : Natural) return DWord; - function Shift_Right (Value : DWord; Amount : Natural) return DWord; - function Rotate_Left (Value : DWord; Amount : Natural) return DWord; - function Rotate_Right (Value : DWord; Amount : Natural) return DWord; - - pragma Import (Intrinsic, Shift_Left); - pragma Import (Intrinsic, Shift_Right); - - function Shift_Left (Value : Bytes; Amount : Natural) return Bytes; - function Shift_Left (Value : B_Block128; Amount : Natural) return B_Block128; - function Shift_Right(Value : Bytes; Amount : Natural) return Bytes; - function Shift_Right(Value : B_Block128; Amount : Natural) return B_Block128; - - --Operations for Bytes - function "xor"(Left, Right : Bytes) return Bytes; - function "xor"(Left : Bytes; Right : Byte) return Bytes; - function "+"(Left : Bytes; Right : Byte) return Bytes; - function "+"(Left : Byte; Right : Bytes) return Bytes; - function "and"(Left, Right : Bytes) return Bytes; - - - -- Operations for Words - function "xor"(Left, Right : Words) return Words; - function "+"(Left : Words; Right : Word) return Words; - function "+"(Left : Word; Right : Words) return Words; - function "+"(Left : Words; Right : Byte) return Words; - - - -- Operations for DWords - function "xor"(Left, Right : DWords) return DWords; - function "+"(Left : DWords; Right : DWord) return DWords; - function "+"(Left : DWord; Right : DWords) return DWords; - function "+"(Left : DWords; Right : Byte) return DWords; - - -- Bytes to Word - function To_Word (A,B,C,D : Byte) return Word; - function To_Word (X : Byte_Word) return Word; - function R_To_Word (X : Byte_Word) return Word; -- reverse - function To_Words(Byte_Array : Bytes) return Words; - - -- Word to Bytes - function To_Bytes (X : Word) return Byte_Word; - function R_To_Bytes (X : Word) return Byte_Word; --reverse - function To_Bytes(Word_Array : Words) return Bytes; - - --Word = b_0 b_1 b2 b_3 - -- ByteX returns b_n - function Byte0 (W : Word) return Byte; - function Byte1 (W : Word) return Byte; - function Byte2 (W : Word) return Byte; - function Byte3 (W : Word) return Byte; - - -- Bytes to DWord - function To_DWord (X : Byte_DWord) return DWord; - function R_To_DWord (X : Byte_DWord) return DWord; - function To_DWords (Byte_Array : Bytes) return DWords; - - -- DWord to Bytes - function To_Bytes (X : DWord) return Byte_DWord; - function R_To_Bytes (X : DWord) return Byte_DWord; - function To_Bytes (DWord_Array : DWords) return Bytes; - - - --DWord = b_0 b_1 b2 b_3 b_4 b_5 b_6 b_7 - -- ByteX returns b_n - function Byte0 (D : DWord) return Byte; - function Byte1 (D : DWord) return Byte; - function Byte2 (D : DWord) return Byte; - function Byte3 (D : DWord) return Byte; - function Byte4 (D : DWord) return Byte; - function Byte5 (D : DWord) return Byte; - function Byte6 (D : DWord) return Byte; - function Byte7 (D : DWord) return Byte; - - -- To_Word - function To_Word (A,B,C,D : Character) return Word; - - -- String to Bytes - function To_Bytes(Message : String) return Bytes; - - -- Bytes to String - function To_String(ASCII : Bytes) return String; - - - -- To_Hex - function To_Hex(B : Byte) return Hex_Byte; - function To_Hex(W : Word) return Hex_Word; - function To_Hex(D : DWord) return Hex_DWord; - - -- To_Bytes - function Hex_To_Bytes(Hex : String) return Bytes; - - -- Is_Zero - -- returns only true if the "input array" X = (others => 0) - function Is_Zero(Byte_Array : Bytes) return Boolean; - function Is_Zero(Word_Array : Words) return Boolean; - function Is_Zero(DWord_Array : DWords) return Boolean; - - - -- Byte Blocks To Bytes. - -- Needed for generic packages to convert a specific byte block. - function To_Bytes(B : B_Block64) return Bytes; - function To_Bytes(B : B_Block128) return Bytes; - function To_Bytes(B : B_Block192) return Bytes; - function To_Bytes(B : B_Block256) return Bytes; - function To_Bytes(W : W_Block160) return Bytes; - function To_Bytes(W : W_Block256) return Bytes; - function To_Bytes(W : W_Block512) return Bytes; - function To_Bytes(D : DW_Block256) return Bytes; - function To_Bytes(D : DW_Block384) return Bytes; - function To_Bytes(D : DW_Block512) return Bytes; - function To_Bytes(D : DW_Block1024) return Bytes; - function To_Bytes(D : DW_Block8192) return Bytes; - - - -- Bytes To block of Bytes. - -- Needed for generic packages to convert a specific byte block. - function To_B_Block64(B : Bytes) return B_Block64; - function To_B_Block128(B : Bytes) return B_Block128; - function To_B_Block192(B : Bytes) return B_Block192; - function To_B_Block256(B : Bytes) return B_Block256; - - - -- Bytes To block of words. - -- Needed for generic packages to convert a specific byte block. - function To_W_Block160(B : Bytes) return W_Block160; - function To_W_Block256(B : Bytes) return W_Block256; - function To_W_Block512(B : Bytes) return W_Block512; - - - -- Bytes To block of double words. - -- Needed for generic packages to convert a specific byte block. - function To_DW_Block256(B : Bytes) return DW_Block256; - function To_DW_Block384(B : Bytes) return DW_Block384; - function To_DW_Block512(B : Bytes) return DW_Block512; - function To_DW_Block1024(B : Bytes) return DW_Block1024; - function To_DW_Block8192(B : Bytes) return DW_Block8192; - - -- Needed for generic packages to convert a specific byte block. - function "xor"(Left, Right : B_Block64) return B_Block64; - function "xor"(Left, Right : B_Block128) return B_Block128; - function "xor"(Left, Right : W_Block160) return W_Block160; - function "xor"(Left, Right : W_Block256) return W_Block256; - function "xor"(Left, Right : W_Block512) return W_Block512; - function "xor"(Left, Right : DW_Block512) return DW_Block512; - function "xor"(Left, Right : DW_Block1024) return DW_Block1024; - function "xor"(Left, Right : DW_Block8192) return DW_Block8192; - - function "+"(Left : B_Block128; Right : Byte) return B_Block128; - - - -- Splits byte array of length n into a left part of length - -- ceiling(n/2) and a right part of length floor(n/2). - function Left_Part(Block : in Bytes) return Bytes; - function Right_Part(Block : in Bytes) return Bytes; - - - - -- Nested generic package - generic - type T is mod <>; - type T_A is array (Integer range <>) of T; - with function Shift_Left (Value : T; Amount : Natural) return T is <>; - with function Shift_Right (Value : T; Amount : Natural) return T is <>; - - package Generic_Mod_Aux is - function "xor"(Left, Right : T_A) return T_A; - function "xor"(Left : T_A; Right : T) return T_A; - function "xor"(Left : T; Right : T_A) return T_A; - - function "and"(Left, Right : T_A) return T_A; - - function "+"(Left : T_A; Right : T) return T_A; - function "+"(Left : T; Right : T_A) return T_A; - - function Is_Zero(Item : T_A) return Boolean; - - function Left_Part (Block : in T_A) return T_A; - function Right_Part(Block : in T_A) return T_A; - - function Shift_Left(Value : T_A; Amount : Natural) return T_A; - function Shift_Right(Value : T_A; Amount : Natural) return T_A; - end Generic_Mod_Aux; - - - - --------------------------------------------------------------------------- - -------------------------------PRIVATE------------------------------------- - --------------------------------------------------------------------------- - -private - pragma Inline (To_B_Block128,To_B_Block192,To_B_Block256); - pragma Inline ("xor","+"); - pragma Inline (R_To_Bytes, To_Bytes); - pragma Inline (To_Word, Byte0, Byte1, Byte2, Byte3); - pragma Inline (Byte4, Byte5, Byte6, Byte7); - pragma Inline (To_DWord, R_To_DWord); - pragma Inline (Is_Zero); - pragma Inline (Left_Part, Right_Part); - pragma Import (Intrinsic, Rotate_Left); - pragma Import (Intrinsic, Rotate_Right); - - pragma Optimize(Time); -end Crypto.Types; diff --git a/src/crypto.ads b/src/crypto.ads deleted file mode 100644 index 2f0ed3c..0000000 --- a/src/crypto.ads +++ /dev/null @@ -1,25 +0,0 @@ --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of the --- License, or (at your option) any later version. - --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. - --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - --- As a special exception, if other files instantiate generics from --- this unit, or you link this unit with other files to produce an --- executable, this unit does not by itself cause the resulting --- executable to be covered by the GNU General Public License. This --- exception does not however invalidate any other reasons why the --- executable file might be covered by the GNU Public License. - - -package Crypto is -end Crypto; diff --git a/src/multi_precision_integers-check.adb b/src/multi_precision_integers-check.adb new file mode 100644 index 0000000..ac0efc4 --- /dev/null +++ b/src/multi_precision_integers-check.adb @@ -0,0 +1,141 @@ +with Ada.Text_IO; use Ada.Text_IO; +-- !! will disappear in favour of Ada.Exceptions + +with Multi_precision_integers.IO; + +package body Multi_precision_integers.Check is + + package IOi renames Multi_precision_integers.IO; + + -- Don't be afraid by the bug reporting tools, + -- they are unlikely to pop out of a programme ;-) + + Bug_file: Ada.Text_IO.File_type; + Bug_file_name: constant String:= "mupreint.bug"; + + -- The flaw detection (DEBUG mode) could suffer from + -- a chicken-and-egg problem: e.g. "*" works, but the "/" + -- to verify it doesn't ! + + Multiply_flawed_div1_has_rest : exception; + Multiply_flawed_div1_wrong_quotient : exception; + Multiply_flawed_div2_has_rest : exception; + Multiply_flawed_div2_wrong_quotient : exception; + + Div_Rem_flawed : exception; + + procedure Open_Bug_Report is + begin + Create( Bug_file, out_file, Bug_file_name ); + Put_Line( Bug_file, "Bug in Multi_precision_integers"); + end Open_Bug_Report; + + procedure Close_Bug_Report is + begin + Close( Bug_file ); + -- These console messages can provoke a silent quit in GUI apps, + -- so we put them after closing the report. + Put_Line( "Bug in Multi_precision_integers !"); + Put_Line( "For details, read file: " & Bug_file_name); + end Close_Bug_Report; + + procedure Test( m: multi_int; test_last: Boolean:= True ) is + last_nz: index_int:= 0; + Negative_block, + Last_index_has_zero, + Field_last_outside_range, Field_last_is_negative: exception; + begin + if m.zero then return; end if; -- 0, nothing to test + if m.last_used > m.n then raise Field_last_outside_range; end if; + if m.last_used < 0 then raise Field_last_is_negative; end if; + for i in 0 .. m.last_used loop + if m.blk(i) < 0 then + raise Negative_block; + end if; + if m.blk(i) /= 0 then + last_nz:= i; + end if; + end loop; + if test_last and then 0 < last_nz and then last_nz < m.last_used then + raise Last_index_has_zero; + end if; + end Test; + + procedure Check_Multiplication(i1,i2,i3: in multi_int) is + jeu: constant:= 5; -- 0 suffit + q1: Multi_int( i2.last_used + jeu ); + r1: Multi_int( i1.last_used + i2.last_used + jeu ); + q2: Multi_int( jeu ); + r2: Multi_int( i2.last_used + jeu ); + + procedure Bug_Report is + begin + Open_Bug_Report; + Put_Line( Bug_file, "Multiply_and_verify"); + Put( Bug_file, "i1 ="); IOi.Put_in_blocks(Bug_file, i1); New_Line(Bug_file); + Put( Bug_file, "i2 ="); IOi.Put_in_blocks(Bug_file, i2); New_Line(Bug_file); + Put( Bug_file, "i3 ="); IOi.Put_in_blocks(Bug_file, i3); New_Line(Bug_file); + end Bug_Report; + + begin + Test(i1); + Test(i2); + + if not (i1.zero or i2.zero) then + -- Now we divide i3 by i1, q1 should be = i2 + Div_Rem_internal_both_export(i3,i1, q1,r1); + if not r1.zero then + Bug_Report; + Close_Bug_Report; + raise Multiply_flawed_div1_has_rest; + end if; + if not Equal( q1, i2 ) then + Bug_Report; + Put( Bug_file, "q1 ="); IOi.Put_in_blocks(Bug_file, q1); New_Line(Bug_file); + Close_Bug_Report; + raise Multiply_flawed_div1_wrong_quotient; + end if; + -- Now we divide q1 by i2, should be = 1 + Div_Rem_internal_both_export(q1,i2, q2,r2); + if not r2.zero then + Bug_Report; + Close_Bug_Report; + raise Multiply_flawed_div2_has_rest; + end if; + if not Equal( q2, Multi(1) ) then + Bug_Report; + Put( Bug_file, "q2 ="); IOi.Put_in_blocks(Bug_file, q1); New_Line(Bug_file); + Close_Bug_Report; + raise Multiply_flawed_div2_wrong_quotient; + end if; + end if; + + end Check_Multiplication; + + procedure Check_Div_Rem(i1,i2,q,r: in multi_int) is + + procedure Bug_Report is + begin + Open_Bug_Report; + Put_Line( Bug_file, "Div_Rem_and_verify"); + Put( Bug_file, "i1 ="); IOi.Put_in_blocks(Bug_file, i1); New_Line(Bug_file); + Put( Bug_file, "i2 ="); IOi.Put_in_blocks(Bug_file, i2); New_Line(Bug_file); + Put( Bug_file, "q ="); IOi.Put_in_blocks(Bug_file, q); New_Line(Bug_file); + Put( Bug_file, "r ="); IOi.Put_in_blocks(Bug_file, r); New_Line(Bug_file); + end Bug_Report; + + begin + Test(i1); + Test(i2); + + if not Equal( i1, i2*q + r ) then + Bug_Report; + Close_Bug_Report; + raise Div_Rem_flawed; + end if; + + Test(q); + Test(r); + end Check_Div_Rem; + +end Multi_precision_integers.Check; diff --git a/src/multi_precision_integers-check.ads b/src/multi_precision_integers-check.ads new file mode 100644 index 0000000..60895ea --- /dev/null +++ b/src/multi_precision_integers-check.ads @@ -0,0 +1,12 @@ +package Multi_precision_integers.Check is + + -- check integrity + procedure Test (m: Multi_int; test_last: Boolean:= True ); + + -- i3 must be = i1 * i2 + procedure Check_Multiplication (i1, i2,i3: in Multi_int); + + -- i1 must be = i2 * q + r + procedure Check_Div_Rem (i1, i2,q,r: in Multi_int); + +end Multi_precision_integers.Check; diff --git a/src/multi_precision_integers-io.adb b/src/multi_precision_integers-io.adb new file mode 100644 index 0000000..ca8f1c2 --- /dev/null +++ b/src/multi_precision_integers-io.adb @@ -0,0 +1,186 @@ +----------------------------------------------------------------------------- +-- File: muprinio.adb; see specification (muprinio.ads) +----------------------------------------------------------------------------- + +package body Multi_precision_integers.IO is + + package IIO is new Integer_IO( index_int ); + + table: constant array(basic_int'(0)..15) of Character:= + ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); + + -- 15-Feb-2002: Bugfix case i=0. Spotted by Duncan Sands + + function Chiffres_i_non_nul(i: multi_int; base: number_base:= 10) return Natural is + nombre: multi_int(i.last_used); + la_base : constant basic_int := basic_int(base); + nchiffres: Natural:= 1; + + procedure Comptage_rapide( C: Positive ) is + test : multi_int(i.n); + base_puiss_C: constant multi_int:= Multi( basic_int(base) ) ** C; + begin + loop + Fill(test, nombre / base_puiss_C ); + exit when test.zero; + -- quotient non nul, donc on a au moins C chiffres + Fill(nombre, test); + nchiffres:= nchiffres + C; + end loop; + end Comptage_rapide; + + begin + Fill(nombre, i); + Comptage_rapide( 400 ); + Comptage_rapide( 20 ); + loop + Fill(nombre, nombre / la_base); + exit when nombre.zero; + nchiffres:= nchiffres + 1; + end loop; + return nchiffres; + end Chiffres_i_non_nul; + + function Number_of_digits(i: multi_int; base: number_base:= 10) return Natural is + begin + if i.zero then + return 1; + else + return Chiffres_i_non_nul(i,base); + end if; + end Number_of_digits; + + function Str(i: multi_int; base: number_base:= 10) return String is + res: String(1..1 + Number_of_digits(i,base)):= (others=> 'x'); + nombre : multi_int(i.n):= i; + chiffre: basic_int; + la_base: constant basic_int := basic_int(base); + + begin + if nombre.zero or else not nombre.neg then + res(1):= ' '; + else + res(1):= '-'; + end if; + nombre.neg:= False; + + -- maintenant nombre et base sont >=0, MOD=REM + for k in reverse 2 .. res'Last loop + Div_Rem( nombre, la_base, nombre, chiffre ); + res(k):= table( chiffre ); + exit when nombre.zero; + end loop; + return res; + + end Str; + + +-- !!! recursion !!! + + function Val(s: String) return multi_int is + formatting_error: exception; + begin + if s="" then + return Multi(0); + elsif s(s'First)='-' then + return -Val(s(s'First+1..s'Last)); + elsif s(s'First)='+' then + return Val(s(s'First+1..s'Last)); + elsif s(s'Last) in '0'..'9' then + return basic_int'Value(s(s'Last..s'Last)) + 10 * + Val(s(s'First..s'Last-1)); + else + raise formatting_error; + end if; + end Val; + + procedure Put_in_blocks(File : in File_Type; + Item : in multi_int) is + begin + if Item.neg then put(File,'-'); else put(File,'+'); end if; + Put(File, " [ "); + IIO.Put(File, 1+Item.n , 3); + Put(File, " blocks ]: "); + Put(File,'{'); + if Item.n > Item.last_used then + IIO.Put(File, Item.n - Item.last_used, 3); + Put(File, " unused |"); + end if; + for k in reverse 0 .. Item.last_used loop + Put(File, Block_type'Image(Item.blk(k))); + if k>0 then Put(File,'|'); end if; + end loop; + Put(File,'}'); + end Put_in_blocks; + + procedure Put_in_blocks(Item : in multi_int) is + begin + Put_in_blocks( Standard_Output, Item ); + end Put_in_blocks; + + procedure Get(File : in File_Type; + Item : out multi_int; + Width : in Field := 0) is + begin + null; -- !!! + end Get; + + procedure Get(Item : out multi_int; + Width : in Field := 0) is + + begin + Get(Standard_Input, Item, Width); + end Get; + + + procedure Put(File : in File_Type; + Item : in multi_int; + Width : in Field := 0; + Base : in Number_Base := Default_Base) is + + begin + if Width = 0 then -- No padding required (default) + Put(File, Str(Item, Base)); + else -- Left padding required -> slow + declare + la_chaine: String(1..Width); + begin + Put(la_chaine, Item, Base); + Put(File, la_chaine); + end; + end if; + end Put; + + procedure Put(Item : in multi_int; + Width : in Field := 0; + Base : in Number_Base := Default_Base) is + + begin + Put(Standard_Output, Item, Width, Base); + end Put; + + procedure Get(From : in String; + Item : out multi_int; + Last : out Positive) is + begin + Last:= 1; + null; -- !!! + end Get; + + + procedure Put(To : out String; + Item : in multi_int; + Base : in Number_Base := Default_Base) is + + nchiffres: constant Natural:= Number_of_digits(Item, Base); + blancs: constant String(To'Range):= (others=> ' '); + begin + if nchiffres > To'Length then + raise Layout_Error; + else + To:= blancs; + To( To'Last - nchiffres .. To'Last ):= Str(Item, Base); + end if; + end Put; + +end Multi_precision_integers.IO; diff --git a/src/multi_precision_integers-io.ads b/src/multi_precision_integers-io.ads new file mode 100644 index 0000000..1544d3c --- /dev/null +++ b/src/multi_precision_integers-io.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- File: Multi_precision_integers-IO.ads +-- Description: Child of package 'Multi_precision_integers: I/O +-- Date/version: 2006 ; 15-Feb-2002 / 22.XI.1999 / 22.12.1996 +-- Author: Gautier de Montmollin +------------------------------------------------------------------------------ +with Text_IO; use Text_IO; + +package Multi_precision_integers.IO is + + Default_Base: Number_Base := 10; + + -- Returns the number of digits in the specified base: + function Number_of_digits(i: Multi_int; base: Number_Base:= 10) return Natural; + + -- Returns the image of i in the specified base: + function Str(i: Multi_int; base: Number_Base:= 10) return String; + + -- Returns the value of number in string: + function Val(s: String) return Multi_int; + + -- Output to file, in block format: + procedure Put_in_blocks(File : in File_Type; + Item : in Multi_int); + + -- Output to standard input, in block format: + procedure Put_in_blocks(Item : in Multi_int); + + ---- The following mimic the Text_IO.Integer_IO + + -- Get from file: + procedure Get(File : in File_Type; + Item : out Multi_int; + Width : in Field := 0); + + -- Get from standard input: + procedure Get(Item : out Multi_int; + Width : in Field := 0); + + -- Put to file: + procedure Put(File : in File_Type; + Item : in Multi_int; + Width : in Field := 0; + Base : in Number_Base := Default_Base); + -- Width=0 : no default formatting, since inpredicatble length + + -- Put to standard output: + procedure Put(Item : in Multi_int; + Width : in Field := 0; + Base : in Number_Base := Default_Base); + -- Width=0 : no default formatting, since inpredicatble length + + -- Get from string: + procedure Get(From : in String; + Item : out Multi_int; + Last : out Positive); + + -- Put to string: + procedure Put(To : out String; + Item : in Multi_int; + Base : in Number_Base := Default_Base); + +end Multi_precision_integers.IO; diff --git a/src/multi_precision_integers.adb b/src/multi_precision_integers.adb new file mode 100644 index 0000000..4d8d876 --- /dev/null +++ b/src/multi_precision_integers.adb @@ -0,0 +1,1500 @@ +----------------------------------------------------------------------------- +-- File: mupreint.adb; see specification (mupreint.ads) +----------------------------------------------------------------------------- +-- Aug-2007: - No more generics (Long_Block_type, +-- Block_type,... always the largest possible idea: J.C.) +-- - Fixed Basic(...) (based on J.C.'s remarks) +-- Nov-2006: - Multiply_internal with/without copy of result (automatic +-- detection of when it is needed) +-- - Explicit Multiply_internal for Multi_int * Basic_int +-- - Multiply(multi,basic,multi) available as procedure +-- - useless zeroing of quotient removed +-- - useless zeroing of blocks removed for indices +-- above last possible used in * +-- 24-Feb-2002: Div_Rem(u, v, v, r) also possible +-- 23-Feb-2002: DEBUG: +: multiplications are verified by dividing the result +-- +: divisions are verified by comparing i2*q+r and i1 +-- 15-Feb-2002: "zero" and 1st index in Divide_absolute_normalized +-- bugs fixed by Duncan Sands (D.S.) + +-- To-do/bug symbol: !! + +with Multi_precision_integers.Check; +-- with Ada.Text_IO; +with Ada.Unchecked_Deallocation; + +package body Multi_precision_integers is + + function Shift_Left + (Value : Block_type; + Amount : Natural) return Block_type; + + function Shift_Right + (Value : Block_type; + Amount : Natural) return Block_type; + + function Shift_Left + (Value : Long_Block_type; + Amount : Natural) return Long_Block_type; + + function Shift_Right + (Value : Long_Block_type; + Amount : Natural) return Long_Block_type; + + pragma Import (Intrinsic, Shift_Left); + pragma Import (Intrinsic, Shift_Right); + + package Check_internal renames Multi_precision_integers.Check; + + -- Internal_error: exception; + -- Not_done: exception; + + type compar is (smaller, equal, greater); + + function Min (a,b: Index_int) return Index_int is + begin if a < b then return a; else return b; end if; end Min; + + function Max (a,b: Index_int) return Index_int is + begin if a > b then return a; else return b; end if; end Max; + + procedure Reduce_last_nonzero ( n: in out Multi_int ) is + old_last : constant Index_int:= n.last_used; + begin + if Debug then Check_internal.Test(n, test_last=> False); end if; + + if n.zero then -- We avoid de-zeroing accidentally + return; -- and returning a false non-zero with rubbish :-) + end if; + + n.zero := True; + for i in 0 .. old_last loop -- after old_last it *is* rubbish anyway. + if n.blk(i) /= 0 then + n.zero := False; + n.last_used := i; + end if; + end loop; + end Reduce_last_nonzero; + + function Compare_absolute (i1, i2: Multi_int) return compar is + l1, l2 : Index_int; + begin + -- On ne compare que ABS(i1) et ABS(i2) + l1:= i1.last_used; + l2:= i2.last_used; + if l1 > l2 then -- i1 a plus de blocs non nuls + return greater; + elsif l1 < l2 then -- i1 a moins de blocs non nuls + return smaller; + else -- i1 et i2 ont le meme nb de blocs + for i in reverse 0 .. l1 loop -- on parcourt du + signifiant au - + if i1.blk(i) > i2.blk(i) then -- <> de i1 plus grand + return greater; + elsif i1.blk(i) < i2.blk(i) then -- <> de i1 plus petit + return smaller; + end if; + -- M\^emes chiffres -> au suivant! + end loop; + -- Bon, les 2 nombres sont egaux! + return equal; + end if; + end Compare_absolute; + + ----- Informations, conversions + + function Multi(small: Basic_int) return Multi_int is + abss: constant Long_Block_type:= Long_Block_type(abs small); + reste: Long_Block_type; + negs: constant Boolean:= small < 0; + Conversion_overflow : exception; + + begin + + if abss <= Long_Block_type(maxblock) then + return Multi_int' + ( n=> 0, -- 1 bloc suffit + blk=> (0=> Block_type(abss)), -- le bloc contient le nombre + neg=> negs, + zero=> small = 0, + last_used=> 0 + ); + else + reste:= Shift_Right(abss, Block_type_bits); + if reste <= Long_Block_type(maxblock) then + return ( n=> 1, -- il faut 2 blocs + blk=> (0=> Block_type(abss and maxblock), -- bloc 0 + 1=> Block_type(reste)), -- bloc 1 + neg=> negs, + zero=> False, + last_used=> 1 + ); + else + if Shift_Right(reste, Block_type_bits) > Long_Block_type(maxblock) then + raise Conversion_overflow; + end if; + + return ( n=> 2, -- il faut 3 blocs (e.g. 31 bits 15+15+1) + blk=> (0=> Block_type(abss and maxblock), -- bloc 0 + 1=> Block_type(reste and maxblock), -- bloc 1 + 2=> Block_type(Shift_Right(reste, Block_type_bits)) -- bloc 2 + ), + neg=> negs, + zero=> False, + last_used=> 2 + ); + end if; + end if; + end Multi; + + zero: constant Multi_int:= Multi(0); + one : constant Multi_int:= Multi(1); + + Blocks_Per_Basic : constant Positive := + (Basic_int'Size + Block_type'Size - 1) / Block_type'Size; + + -- Convert Multi_int to Basic_int (when possible, else: Cannot_fit raised) + -- 2007: + -- - correct code for block sizes smaller than Basic_int + -- - fixed usage of negative flag + function Basic(large: Multi_int) return Basic_int is + type Same_as_Basic_natural is mod 2 ** Basic_int'Size; + function Shift_Left + (Value : Same_as_Basic_natural; + Amount : Natural) return Same_as_Basic_natural; + pragma Import (Intrinsic, Shift_Left); + result : Same_as_Basic_natural; + block_value: Block_type; + type Huge_int is mod System.Max_Binary_Modulus; + last_bit: Natural; + begin + if large.zero then -- <- 17-Feb-2002 + return 0; + end if; + -- Case: too many blocks (whatever sizes) + if 1 + large.last_used > Blocks_Per_Basic then + raise Cannot_fit; + end if; + -- Case: block size and contents larger than basic + block_value:= large.blk(large.last_used); + if Huge_int(block_value) > Huge_int(Basic_int'Last) then + raise Cannot_fit; + end if; + declare + tmp: Block_type:= block_value; + begin + last_bit:= 0; + while tmp /= 0 loop + tmp:= tmp / 2; + last_bit:= last_bit + 1; + end loop; + end; + result:= Same_as_Basic_natural(block_value); + -- If the following loop was on all blocks, + -- the shift by Block_type_bits in the loop could do meaningless + -- things the case Basic_int'Size <= Block_Type'Size + for b in reverse 0 .. large.last_used-1 loop + result:= Shift_Left(result, Block_type_bits); + -- An overflow is not detected by shifting (it's the way we want it!) + -- so we need to detect the overall overflow by locating the + -- last bit. + last_bit:= last_bit + Block_type_bits; + if last_bit > Basic_int'Size - 1 then + -- ^ "- 1" because of sign bit in Basic_int + raise Cannot_fit; + end if; + result:= result + Same_as_Basic_natural(large.blk(b)); + end loop; + if large.neg then + return -Basic_int(result); + else + return Basic_int(result); + end if; + end Basic; + + -- 14-Feb-2002: "zero" bug fixed by Duncan Sands + procedure Fill(what: out Multi_int; with_smaller:Multi_int) is + l: constant Index_int:= with_smaller.last_used; + begin + if Debug then Check_internal.Test(with_smaller); end if; + what.zero:= with_smaller.zero; + + if with_smaller.zero then + return; + end if; + + if what.n < l then + raise Array_too_small; -- contenant trop petit + end if; + + what.blk(0..l):= with_smaller.blk(0..l); -- copy contents + what.neg:= with_smaller.neg; + what.last_used:= l; + end Fill; + + procedure Fill(what:out Multi_int; with_basic: Basic_int) is + begin + Fill( what, Multi(with_basic) ); + end Fill; + + function Bits_per_block return Positive is + begin + return Block_type_bits; + end Bits_per_block; + + --------------------------- + ----- Unary operators ----- + --------------------------- + + function "+" (i: Multi_int) return Multi_int is begin return i; end "+"; + + procedure Opp(i: in out Multi_int) is + begin + i.neg:= not i.neg; -- -0 possible, anyway i.zero = True in such a case + end Opp; + + function "-" (i: Multi_int) return Multi_int is + res: Multi_int(i.n):= i; -- copy + stack :-( + begin + Opp(res); + return res; + end "-"; + + procedure Abso(i: in out Multi_int) is + begin + i.neg:= False; + end Abso; + + function "Abs" (i: Multi_int) return Multi_int is + abs_i: Multi_int(i.n):= i; -- copy + stack :-( + begin + if Debug then Check_internal.Test(i); end if; + abs_i.neg:= False; + return abs_i; + end "Abs"; + + function Sign(i: Multi_int) return Basic_int is + begin + if i.zero then return 0; + elsif i.neg then return -1; + else return +1; + end if; + end Sign; + + function Even(i: Multi_int) return Boolean is + begin + return i.zero or i.blk(0) mod 2 = 0; + end Even; + + function Odd (i: Multi_int) return Boolean is + begin + return (not i.zero) and i.blk(0) mod 2 = 1; + end Odd; + + ---------------------------- + ----- Binary operators ----- + ---------------------------- + + -- Internal algorithm to add two numbers AS POSITIVE ( > 0 ) ! + + procedure Add_absolute(i1,i2: in Multi_int; i3: out Multi_int) is + l1: constant Index_int:= i1.last_used; + l2: constant Index_int:= i2.last_used; + min_ind: constant Index_int:= Min( l1, l2 ); + max_ind: constant Index_int:= Max( l1, l2 ); + s: Long_Block_type:= 0; + retenue_finale: Block_type; + begin + if Debug then Check_internal.Test(i1); Check_internal.Test(i2); end if; + + if max_ind > i3.n then + raise Result_undersized; + end if; -- 17-Feb-2002 + + -- (1) On additionne sur le <> + for ind in 0 .. min_ind loop + s:= Long_Block_type(i1.blk(ind)) + Long_Block_type(i2.blk(ind)) + + Shift_Right(s, Block_type_bits); -- (retenue) + i3.blk(ind):= Block_type(s and maxblock); + -- NB: dans un cas de Add(a,b,a) ou Add(a,b,b), + -- i1.blk(ind) ou i2.blk(ind) est modifie en meme temps! + end loop; + + -- (2) On poursuit au besoin si i1 a plus de blocs... + if l1 > min_ind then + for ind in min_ind+1 .. max_ind loop + s:= Long_Block_type(i1.blk(ind)) + + Shift_Right(s, Block_type_bits); -- (retenue) + i3.blk(ind):= Block_type(s and maxblock); + end loop; + -- ... ou bien si i2 en a plus. + elsif l2 > min_ind then + for ind in min_ind+1 .. max_ind loop + s:= Long_Block_type(i2.blk(ind)) + + Shift_Right(s, Block_type_bits); -- (retenue) + i3.blk(ind):= Block_type(s and maxblock); + end loop; + end if; + + -- (3) Il peut rester une retenue + retenue_finale:= Block_type(Shift_Right(s, Block_type_bits)); + if retenue_finale /= 0 then + if max_ind+1 > i3.n then + raise Result_undersized; + end if; -- 17-Feb-2002 + i3.blk(max_ind+1):= retenue_finale; + i3.last_used:= max_ind+1; + else + i3.last_used:= max_ind; + end if; + + -- (4) i3 = i1+i2 > 0 + i3.neg:= False; + i3.zero:= False; + + end Add_absolute; + + -- Internal algorithm to subtract two numbers AS POSITIVE ( > 0 ) ! + + procedure Sub_absolute(i1,i2: in Multi_int; i3: in out Multi_int; + sgn: out Boolean) is + l1: constant Index_int:= i1.last_used; + l2: constant Index_int:= i2.last_used; + max_ind: constant Index_int:= Max( l1, l2 ); + ai, bi: Long_Block_type; + s: Block_type; + retenue_finale: Long_Block_type; + begin + if Debug then Check_internal.Test(i1); Check_internal.Test(i2); end if; + + if max_ind > i3.n then raise Result_undersized; end if; -- 17-Feb-2002 + + i3.last_used:= 0; + i3.zero:= True; + s:= 0; + + -- (1) Soustraction avec retenue + for ind in 0 .. max_ind loop + if ind <= l1 then + ai:= Long_Block_type(i1.blk(ind)); + else + ai:= 0; + end if; + if ind <= l2 then + bi:= Long_Block_type(i2.blk(ind)) + Long_Block_type(s); + else + bi:= Long_Block_type(s); + end if; + + if ai < bi then + ai:= ai + cardblock; + s:= 1; + else + s:= 0; + end if; + + i3.blk(ind):= Block_type(ai-bi); + -- NB: dans un cas de Sub(a,b,a) ou Sub(a,b,b), + -- i1.blk(ind) ou i2.blk(ind) est modifie en meme temps! + + if i3.blk(ind) /= 0 then -- au passage, on corrige .last_used et .zero + i3.last_used:= ind; + i3.zero:= False; + end if; + end loop; + + -- (2) Traitement de la derni\`ere retenue + if s = 0 then + i3.neg := False; + sgn := False; + else + i3.neg := True; + sgn := True; + i3.last_used:= 0; + retenue_finale:= 1; -- on fait "9-chaque chiffre" et on ajoute 1 au tout + for i in 0 .. max_ind loop + retenue_finale:= + Long_Block_type(maxblock) - + Long_Block_type(i3.blk(i)) + retenue_finale; + i3.blk(i):= Block_type(retenue_finale and maxblock); + if i3.blk(i) /= 0 then + i3.last_used:= i; + end if; + retenue_finale:= Shift_Right(retenue_finale, Block_type_bits); + end loop; + end if; + + end Sub_absolute; + + procedure Add(i1,i2: in Multi_int; i3: in out Multi_int) is + sgn: Boolean; + begin + -- (1) Les cas o\`u i1 ou i2 = 0 + if i1.zero and i2.zero then + i3.zero:= True; + elsif i1.zero then + Fill( i3, i2 ); + elsif i2.zero then + Fill( i3, i1 ); + -- (2) Maintenant: i1 /= 0 et i2 /= 0; on regarde les signes + -- (2.1) Facile: i1 et i2 de m\^eme signe + elsif i1.neg = i2.neg then + Add_absolute( i1,i2, i3 ); -- On fait comme si i1>0 et i2>0 + i3.neg:= i1.neg; -- et on met le bon signe + -- (2.2) i1 < 0, i2 > 0, donc i3 = i2 - abs(i1) + elsif i1.neg and not i2.neg then + Sub_absolute( i2,i1, i3, sgn); + -- (2.3) i1 > 0, i2 < 0, donc i3 = i1 - abs(i2) + elsif i2.neg and not i1.neg then + Sub_absolute( i1,i2, i3, sgn ); + end if; + end Add; + + function "+" (i1,i2: Multi_int) return Multi_int is + somme: Multi_int( Max(i1.n, i2.n) + 1 ); + begin + Add( i1,i2, somme ); + return somme; + end "+"; + + procedure Sub(i1,i2: in Multi_int; i3: in out Multi_int) is + sgn: Boolean; + begin + -- (1) Les cas o\`u i1 ou i2 = 0 + if i1.zero and i2.zero then i3.zero:= True; + elsif i1.zero then Fill( i3, i2 ); i3.neg:= not i2.neg; + elsif i2.zero then Fill( i3, i1 ); + + -- (2) Maintenant: i1 /= 0 et i2 /= 0; on regarde les signes + + -- (2.1) Facile: i1 et i2 de m\^eme signe + elsif i1.neg = i2.neg then + Sub_absolute( i1,i2, i3, sgn ); -- On fait comme si i1>0 et i2>0 + -- et on met le bon signe + i3.neg:= i1.neg xor sgn; + -- 26-Mar-2002: equivalent a: + -- if i1.neg then + -- i3.neg:= NOT sgn; + -- else + -- i3.neg:= sgn; + -- end if; + + -- (2.2) i1 < 0, i2 > 0, donc i3 = i1-i2 = - (abs(i1) + abs(i2)) + elsif i1.neg and not i2.neg then + Add_absolute( i1,i2, i3 ); + i3.neg:= True; + + -- (2.3) i1 > 0, i2 < 0, donc i3 = i1-i2 = i1 + (-i2) = i1 + abs(i2) + elsif i2.neg and not i1.neg then + Add_absolute( i1,i2, i3 ); + end if; + + end Sub; + + function "-" (i1,i2: Multi_int) return Multi_int is + diff: Multi_int( Max(i1.n, i2.n) + 1); -- +1: retenue possible (add_abs.) + begin + Sub( i1,i2, diff ); + return diff; + end "-"; + + function "+" (i1: Multi_int; i2: Basic_int) return Multi_int is + begin return i1 + Multi(i2); end "+"; + + function "+" (i1: Basic_int; i2: Multi_int) return Multi_int is + begin return Multi(i1) + i2; end "+"; + + function "-" (i1: Multi_int; i2: Basic_int) return Multi_int is + begin return i1 - Multi(i2); end "-"; + + function "-" (i1: Basic_int; i2: Multi_int) return Multi_int is + begin return Multi(i1) - i2; end "-"; + + ----- Begin of MULTIPLICATION part ----- + + -- Added 2006: choice to copy result into i3 or write directly into i3 + generic + copy: Boolean; + procedure Multiply_internal_m_m(i1,i2: in Multi_int; i3: in out Multi_int); + + type p_Block_array is access Block_array; + procedure Dispose is new Ada.Unchecked_Deallocation(Block_array,p_Block_array); + + ------------------- + -- Multi * Multi -- + ------------------- + + -- To do: implement a faster algorithm. + -- 1) Karatsuba's algorithm + -- Ada code for string arithm exists !! + -- http://www.csc.liv.ac.uk/~ped/teachadmin/algor/karatsuba.ada + -- 2) Better: Schönhage-Strassen algorithm (no Ada code) + + procedure Multiply_internal_m_m(i1,i2: in Multi_int; i3: in out Multi_int) is + l1: constant Index_int:= i1.last_used; + l2: constant Index_int:= i2.last_used; + last_max: constant Index_int:= l1 + l2 + 2; + prod,sum_carry,rk,i1j : Long_Block_type; + i,k: Index_int; + res: p_Block_array; + -- res: buffer used in the "copy" variant to avoid + -- problems with Multiply(i,j,i) or Multiply(j,i,i) + begin + if i1.zero or i2.zero then + i3.zero:= True; + return; + end if; + + if last_max > i3.n then + raise Result_undersized; + end if; + + if copy then + res:= new Block_array( 0..last_max ); + for k in res'Range loop res(k):= 0; end loop; + -- Seems slower :-( : res:= new Block_array'( 0..last_max => 0); + else + for k in 0..last_max loop i3.blk(k):= 0; end loop; + -- Slower :-( : i3.blk(0..last_max):= (others => 0); + end if; + + i3.zero:= False; + i3.last_used:= last_max; + -- NB: va changer i1.last_used ou i2.last_used si + -- i1 ou i2 et i3 sont les memes + + for j in 0..l1 loop + i1j:= Long_Block_type(i1.blk(j)); + sum_carry:= 0; + i:= 0; + k:= j; + loop + if i <= l2 then + prod:= i1j * Long_Block_type(i2.blk(i)); + else + exit when sum_carry = 0; -- nothing more to add + prod:= 0; + end if; + if copy then + rk:= Long_Block_type(res(k)); + else + rk:= Long_Block_type(i3.blk(k)); + end if; + sum_carry:= rk + prod + sum_carry; + if copy then + res(k):= Block_type(sum_carry and maxblock); -- somme + else + i3.blk(k):= Block_type(sum_carry and maxblock); -- somme + end if; + sum_carry:= Shift_Right(sum_carry, Block_type_bits); -- retenue + i:= i + 1; + k:= k + 1; + end loop; + end loop; + + if copy then + i3.blk(res'Range):= res.all; + Dispose(res); + end if; + + Reduce_last_nonzero( i3 ); + + i3.neg:= i1.neg /= i2.neg; + + end Multiply_internal_m_m; + + procedure Multiply_internal_copy is + new Multiply_internal_m_m( copy => True ); + procedure Multiply_internal_copy_export(i1,i2: in Multi_int; i3: in out Multi_int) + renames Multiply_internal_copy; + -- ^ At least GNAT <= GPL 2006 requires the trick with renames... + -- ObjectAda 7.2.2 too -> there must be a good reason... + + procedure Multiply_internal_no_copy is + new Multiply_internal_m_m( copy => False ); + + ------------------- + -- Multi * Basic -- + -- added 2006 -- + ------------------- + + generic + copy: Boolean; + procedure Multiply_internal_m_b(i1: in Multi_int; i2: Basic_int; i3: in out Multi_int); + + procedure Multiply_internal_m_b(i1: in Multi_int; i2: Basic_int; i3: in out Multi_int) is + l1: constant Index_int:= i1.last_used; + last_max: constant Index_int:= l1 + 2; + prod,sum_carry,rk,i2a : Long_Block_type; + k: Index_int; + res: p_Block_array; + -- res: buffer used in the "copy" variant to avoid + -- problems with Multiply(i,j,i) or Multiply(j,i,i) + begin + if i1.zero or i2=0 then + i3.zero:= True; + return; + end if; + + if last_max > i3.n then + raise Result_undersized; + end if; + + if copy then + res:= new Block_array( 0..last_max ); + for k in res'Range loop res(k):= 0; end loop; + -- Seems slower :-( : res:= new Block_array'( 0..last_max => 0); + else + for k in 0..last_max loop i3.blk(k):= 0; end loop; + -- Slower :-( : i3.blk(0..last_max):= (others => 0); + end if; + + i3.zero:= False; + i3.last_used:= last_max; + -- NB: va changer i1.last_used ou i2.last_used si i1 ou i2 et i3 sont les memes + i2a:= Long_Block_type(abs i2); + + for j in 0..l1 loop + k:= j; + sum_carry:= 0; + prod:= Long_Block_type(i1.blk(j)) * i2a; + loop + if copy then + rk:= Long_Block_type(res(k)); + else + rk:= Long_Block_type(i3.blk(k)); + end if; + sum_carry:= rk + prod + sum_carry; + if copy then + res(k):= Block_type(sum_carry and maxblock); -- somme + else + i3.blk(k):= Block_type(sum_carry and maxblock); -- somme + end if; + sum_carry:= Shift_Right(sum_carry, Block_type_bits); -- retenue + exit when sum_carry = 0; -- nothing more to add + prod:= 0; + k:= k + 1; + end loop; + end loop; + + if copy then + i3.blk(res'Range):= res.all; + Dispose(res); + end if; + + Reduce_last_nonzero( i3 ); + + i3.neg:= i1.neg /= (i2 < 0); + + end Multiply_internal_m_b; + + procedure Multiply_internal_copy is + new Multiply_internal_m_b( copy => True ); + + procedure Multiply_internal_no_copy is + new Multiply_internal_m_b( copy => False ); + + procedure Multiply(i1,i2: in Multi_int; i3: in out Multi_int) is + use System; + begin + if Debug then + declare + m1: constant Multi_int:= i1; + m2: constant Multi_int:= i2; + begin + Multiply_internal_no_copy(m1,m2,i3); + Check_internal.Check_Multiplication(m1,m2,i3); + end; + else + if i1'Address = i3'Address or i2'Address = i3'Address then + -- Ada.Text_IO.Put_Line("* with copy"); + Multiply_internal_copy(i1,i2,i3); + else + -- Ada.Text_IO.Put_Line("* without copy"); + Multiply_internal_no_copy(i1,i2,i3); + end if; + end if; + end Multiply; + + procedure Multiply(i1: in Multi_int; i2: Basic_int; i3: in out Multi_int) is + use System; + begin + if Debug then + declare + m1: constant Multi_int:= i1; + m2: constant Basic_int:= i2; + begin + Multiply_internal_no_copy(m1,m2,i3); + Check_internal.Check_Multiplication(m1,Multi(m2),i3); + end; + else + if i1'Address = i3'Address or i2'Address = i3'Address then + -- Ada.Text_IO.Put_Line("* with copy"); + Multiply_internal_copy(i1,i2,i3); + else + -- Ada.Text_IO.Put_Line("* without copy"); + Multiply_internal_no_copy(i1,i2,i3); + end if; + end if; + end Multiply; + + function "*" (i1,i2: Multi_int) return Multi_int is + begin + if i1.zero or i2.zero then + return zero; + else + declare + prod: Multi_int( i1.last_used + i2.last_used + 2 ); + begin + Multiply( i1,i2, prod ); + return prod; + end; + end if; + end "*"; + + function "*" (i1: Multi_int; i2: Basic_int) return Multi_int is + begin + if i1.zero or i2=0 then + return zero; + else + declare + prod: Multi_int( i1.last_used + 4 ); + begin + Multiply( i1,i2, prod ); + return prod; + end; + end if; + end "*"; + + function "*" (i1: Basic_int; i2: Multi_int) return Multi_int is + begin + if i2.zero or i1=0 then + return zero; + else + declare + prod: Multi_int( i2.last_used + 4 ); + begin + Multiply( i2,i1, prod ); + return prod; + end; + end if; + end "*"; + + ----- Begin of DIVISION part ----- + + -- Interne: Division et reste en 1 coup + + procedure Div_Rem(a,b: Long_Block_type; q,r: out Long_Block_type) is + Conflict_with_REM: exception; + begin + q:= a / b; + r:= a - b*q; + if Debug and then r /= (a rem b) then + raise Conflict_with_REM; + end if; + end Div_Rem; + + procedure Divide_absolute_normalized ( u: in out Multi_int; -- output: u = r + v: in Multi_int; + q: in out Multi_int ) is + qi: Index_int:= u.last_used - v.last_used - 1; -- was: q.n; D.S. Feb-2002 + v1: constant Long_Block_type:= Long_Block_type(v.blk(v.last_used )); + v2: constant Long_Block_type:= Long_Block_type(v.blk(v.last_used-1)); + + vlast : constant Index_int:= v.last_used; + v1L : constant Long_Block_type := v1; + guess, + comparand : Long_Block_type ; + + function Divide_subtract ( ustart: Index_int ) return Block_type is + ui : Index_int; + carry : Long_Block_type; + begin + if guess = 0 then + return 0; + end if; + ui:= ustart; + carry:= 0; + + -- On soustrait (le chiffre du quotient) * diviseur au dividende + + for vi in 0 .. vlast loop + declare + prod: constant Long_Block_type := Long_Block_type(v.blk(vi)) * guess + carry; + bpro: constant Block_type:= Block_type(prod and maxblock); + diff: constant Long_Block_type_signed := Long_Block_type_signed(u.blk(ui)) - Long_Block_type_signed(bpro); + begin + if diff < 0 then + u.blk(ui) := Block_type(diff + cardblock); + carry := Shift_Right(prod, Block_type_bits) + 1; + else + u.blk(ui) := Block_type(diff); + carry := Shift_Right(prod, Block_type_bits); + end if; + ui:= ui + 1; + end; + end loop; + + if carry = 0 then + return Block_type(guess and maxblock); + end if; + + declare + diff: constant Long_Block_type_signed := + Long_Block_type_signed(u.blk(ui)) - Long_Block_type_signed(carry and maxblock); + begin + if diff < 0 then + u.blk(ui) := Block_type(diff + cardblock); -- carry generated + else + u.blk(ui) := Block_type(diff); + return Block_type(guess and maxblock); + end if; + end; + + -- Carry was generated + declare + icarry: Block_type := 0; + begin + ui := ustart; + for vi in 0 .. vlast loop + declare + sum: constant Long_Block_type := + Long_Block_type(v.blk(vi)) + + Long_Block_type(u.blk(ui)) + + Long_Block_type(icarry); + begin + u.blk(ui) := Block_type(sum and maxblock); + ui:= ui + 1; + icarry := Block_type(Shift_Right(sum, Block_type_bits)); + end; + end loop; + + if icarry = 1 then + u.blk(ui) := Block_type((Long_Block_type(u.blk(ui))+1) and maxblock); + end if; + end; + + return Block_type((guess-1) and maxblock); + + end Divide_subtract; + + is_q_zero: Boolean:= True; + + begin -- Divide_absolute_normalized + -- for i in q.blk'Range loop q.blk(i):= 0; end loop; + -- + -- ^ zeroing useless: q.last_used = u.last_used-v.last_used-1 + -- and q.blk(0..q.last_used) is written below q.blk(qi) := ... + -- GM 4-nov-2006 + + q.last_used:= qi; -- was: q.n; D.S. Feb-2002 + + for j in reverse vlast+1 .. u.last_used loop + declare + uj : constant Long_Block_type := Long_Block_type(u.blk(j)); + uj1: constant Long_Block_type := Long_Block_type(u.blk(j-1)); + uj2: constant Long_Block_type := Long_Block_type(u.blk(j-2)); + ujL: Long_Block_type; + rmL: Long_Block_type; + begin + ujL := Shift_Left(uj, Block_type_bits) + uj1; + Div_Rem( ujL, v1L, guess, rmL ); + comparand := Shift_Left(rmL, Block_type_bits) + uj2; + + while comparand < v2 * guess loop + guess:= guess - 1; + comparand:= comparand + Shift_Left(v1L, Block_type_bits); + exit when comparand > cardblock * cardblock; + end loop; + + q.blk(qi) := Divide_subtract( j - vlast - 1 ); + + if q.blk(qi) /= 0 and then is_q_zero then -- n'arrive que 0 ou 1 fois + is_q_zero:= False; + q.last_used:= qi; + end if; + + qi:= qi - 1; + end; + + end loop; -- j + + q.zero:= is_q_zero; + + if Debug then Check_internal.Test(q); end if; + + end Divide_absolute_normalized; + + procedure Divide_absolute_big_small ( u: in Multi_int; + v: in Long_Block_type; + q: out Multi_int; + r: out Long_Block_type ) is + n: Long_Block_type; + Quotient_constraint_error: exception; + last_u_nz: constant Index_int:= u.last_used; + u_zero: constant Boolean:= u.zero; + -- in case u and q are the same variables + is_q_zero: Boolean:= True; + begin + if q.n < last_u_nz then raise Quotient_constraint_error; end if; + q.last_used:= 0; + q.neg:= False; + r:= 0; + if not u_zero then + for i in reverse 0 .. last_u_nz loop + n:= Long_Block_type(u.blk(i)) + Shift_Left(r, Block_type_bits); + r:= n mod v; + q.blk(i):= Block_type(n / v); + if q.blk(i)/= 0 and then is_q_zero then + is_q_zero:= False; + q.last_used:= i; + end if; + end loop; + q.zero:= is_q_zero; + end if; + end Divide_absolute_big_small; + + procedure Solve_signs_for_Div_Rem (i1n,i2n: in Boolean; qn,rn: out Boolean) is + begin + -- Invariant: i1= i2*q+r on cherche (pos) = (pos)*(pos)+(pos) + + if i1n and i2n then -- i1<0; i2<0 (-i1) = (-i2) * q + (-r) + qn:= False; -- Quotient > 0 + -- rn:= True; -- Reste < 0 + elsif i1n then -- i1<0; i2>0 (-i1) = i2 *(-q) + (-r) + qn:= True; -- Quotient < 0 + -- rn:= True; -- Reste < 0 + elsif i2n then -- i1>0; i2<0 i1 = (-i2) *(-q) + r + qn:= True; -- Quotient < 0 + -- rn:= False; -- Reste > 0 + else -- i1>0; i2>0 i1 = i2 * q + r + qn:= False; -- Quotient > 0 + -- rn:= False; -- Reste > 0 + end if; + -- on observe que... "(A rem B) has the sign of A " ARM 4.5.5 + -- en effet on peut mettre: + rn:= i1n; + end Solve_signs_for_Div_Rem; + + procedure Div_Rem (i1: in Multi_int; i2: in Basic_int; + q : out Multi_int; r: out Basic_int) is + i1_neg: constant Boolean:= i1.neg; + -- in case i1 and q are the same variables + rneg: Boolean; + lai2, lr: Long_Block_type; + begin + if Debug then Check_internal.Test(i1); end if; + if i2=0 then raise Division_by_zero; end if; + + if i1.zero then -- 15-Feb-2002: 0/i2 + q.zero:= True; + r:= 0; + return; + end if; + + lai2:= Long_Block_type(abs i2); + Divide_absolute_big_small( i1, lai2, q, lr ); + r:= Basic_int(lr); + + Solve_signs_for_Div_Rem( i1_neg,i2<0, q.neg, rneg ); + if rneg then r:= -r; end if; + + end Div_Rem; + + type Div_Rem_mode is (div_only, both); + + generic + div_rem_output: Div_Rem_mode; + procedure Div_Rem_internal (i1,i2: in Multi_int; q,r: in out Multi_int); + + procedure Div_Rem_internal (i1,i2: in Multi_int; q,r: in out Multi_int) is + + -- Calculate u/v + + procedure Divide_absolute ( u,v: in Multi_int; + q,r: in out Multi_int ) is + shift: Integer:= 0; + v1: Block_type:= v.blk(v.last_used); + v_zero, v1_zero: exception; + u_work: Multi_int(u.last_used+2); + use System; + + procedure Normalization ( source: in Multi_int; + target: in out Multi_int ) is + carry: Block_type:= 0; + tl: constant Index_int:= target.last_used; + blk: Block_type; + begin + for i in 0 .. source.last_used loop + blk:= source.blk(i); + target.blk(i) := Shift_Left(blk, shift) + carry; + carry := Shift_Right(blk, Block_type_bits - shift); + end loop; + if source.last_used < tl then + target.blk(source.last_used+1):= carry; + end if; + for i in source.last_used+2 .. tl loop + target.blk(i):= 0; + end loop; + end Normalization; + + procedure Unnormalization ( m: in out Multi_int) is + carry: Block_type:= 0; + blk: Block_type; + begin + for i in reverse 0 .. m.last_used loop + blk:= m.blk(i); + m.blk(i) := Shift_Right(blk, shift) + carry; + carry := Shift_Left(blk, Block_type_bits - shift); + end loop; + end Unnormalization; + + begin -- Divide_absolute (multi u / multi v) + + if Debug then + if v.zero then raise v_zero; end if; + if v1=0 then raise v1_zero; end if; + end if; + + -- Calculate shift needed to normalize + u_work.last_used:= u_work.n; + u_work.zero:= False; + while v1 < 2**(Block_type_bits-1) loop + shift:= shift + 1; + v1:= v1 * 2; + end loop; + if shift = 0 then -- no shift needed + u_work.blk( 0..u.last_used ):= u.blk( 0..u.last_used ); + u_work.blk( u.last_used+1 .. u_work.last_used):= (0,0); + -- Now, u is copied, so a Div_Rem(u, v, u, r) won't crash + + if v'Address = q'Address then + declare + v_work: Multi_int(v.last_used); + begin + -- 23-Feb-2002: also copy v, in case of a Div_Rem(u, v, v, r) + v_work.blk( 0..v.last_used ):= v.blk( 0..v.last_used ); + v_work.neg := v.neg; + v_work.zero := v.zero; + v_work.last_used:= v.last_used; + -- Now, u is copied, so a Div_Rem(u, v, v, r) won't crash + -- Ada.Text_IO.Put_Line("* divisor with copy"); + Divide_absolute_normalized( u_work,v_work, q ); + end; + else + -- Ada.Text_IO.Put_Line("* divisor without copy"); + Divide_absolute_normalized( u_work,v, q ); + end if; + + else -- shift needed + declare + v_work: Multi_int(v.last_used); + begin + v_work.last_used:= v_work.n; + Normalization( u, u_work ); + Normalization( v, v_work ); + Reduce_last_nonzero( v_work ); + + Divide_absolute_normalized( u_work,v_work, q ); + end; + + if div_rem_output /= div_only then + Unnormalization( u_work ); + end if; + end if; + q.neg:= False; -- check friendly + if div_rem_output /= div_only then + u_work.neg:= False; -- check friendly + Reduce_last_nonzero( u_work ); + Fill( r, u_work ); + end if; + + end Divide_absolute; + + l1: constant Index_int:= i1.last_used; + l2: constant Index_int:= i2.last_used; + rl: Long_Block_type; + begin -- Div_Rem_internal + if i2.zero then raise Division_by_zero; end if; + + if i1.zero then -- 15-Feb-2002: 0/i2 + q.zero:= True; + r.zero:= True; + return; + end if; + + if q.n < l1 - l2 then + -- 17-Feb-2002 + raise Quotient_undersized; + end if; + + if div_rem_output /= div_only and then r.n < Max( l1, l2 ) then + -- 17-Feb-2002 + raise Remainder_undersized; + end if; + + if l2 = 0 then + if l1 = 0 then -- On a affaire a une ridicule division d'entiers + q.blk(0):= i1.blk(0) / i2.blk(0); + if div_rem_output /= div_only then + r.blk(0):= Block_type( + abs( + Long_Block_type_signed(i1.blk(0)) + - Long_Block_type_signed(i2.blk(0)) + * Long_Block_type_signed(q.blk(0)) + ) + ); + end if; + q.zero:= q.blk(0) = 0; + q.last_used:= 0; + else -- multi / entier + Divide_absolute_big_small( i1, Long_Block_type(i2.blk(0)), q, rl ); + if div_rem_output /= div_only then + r.blk(0):= Block_type(rl); + end if; + end if; + if div_rem_output /= div_only then + r.zero:= r.blk(0) = 0; + r.last_used:= 0; + end if; + + else -- multi / multi + + case Compare_absolute(i2 , i1) is + + when greater => + q.zero:= True; -- q:= 0; + q.last_used:= 0; + q.neg:= False; + + if div_rem_output /= div_only then + Fill( r, i1 ); -- r:= i1, q:=0 car i1 = 0 * i2 (>i1 en v.abs) + r + end if; + return; + + when equal => + Fill( q, one ); -- Fill( q, Multi(1) ); + r.zero:= True; -- Fill( r, Multi(0) ); + + when smaller => -- cas <>: diviseur < dividende + + Divide_absolute( i1,i2, q,r ); + + end case; + end if; + + Solve_signs_for_Div_Rem( i1.neg,i2.neg, q.neg,r.neg ); + end Div_Rem_internal; + + procedure Div_Rem_internal_div_only is + new Div_Rem_internal( div_rem_output => div_only ); + + procedure Div_Rem_internal_both is + new Div_Rem_internal( div_rem_output => both ); + + procedure Div_Rem_internal_both_export(i1,i2: in Multi_int; q,r: in out Multi_int) + renames Div_Rem_internal_both; + + procedure Div_Rem (i1,i2: in Multi_int; q,r: out Multi_int) is + begin + if Debug then + declare + m1: constant Multi_int:= i1; + m2: constant Multi_int:= i2; + begin + Div_Rem_internal_both(m1,m2,q,r); + Check_internal.Check_Div_Rem(m1,m2,q,r); + end; + else + Div_Rem_internal_both(i1,i2,q,r); + end if; + end Div_Rem; + + procedure Divide (i1,i2: in Multi_int; q: out Multi_int) is + begin + if Debug then + declare + m1: constant Multi_int:= i1; + m2: constant Multi_int:= i2; + r: Multi_int( Max( i1.last_used, i2.last_used) + 2 ); + begin + Div_Rem_internal_both(m1,m2,q,r); + Check_internal.Check_Div_Rem(m1,m2,q,r); + end; + else + declare + r: Multi_int(0); -- Fake + begin + Div_Rem_internal_div_only(i1,i2,q,r); + end; + end if; + end Divide; + + function "/" (i1,i2: Multi_int) return Multi_int is + q: Multi_int( Max( 0, i1.last_used - i2.last_used + 1) ); + r: Multi_int( Max( i1.last_used, i2.last_used) + 2 ); + begin + Div_Rem(i1,i2, q,r); + return q; + end "/"; + + function "/" (i1: Multi_int; i2: Basic_int) return Multi_int is + q: Multi_int(i1.last_used + 1); + r: Basic_int; + begin + Div_Rem(i1,i2, q,r); + return q; + end "/"; + + function "rem" (i1,i2: Multi_int) return Multi_int is + q: Multi_int(Max(0,i1.last_used - i2.last_used + 1)); + r: Multi_int(Max(i1.last_used,i2.last_used) + 2); + begin + Div_Rem(i1,i2, q,r); + return r; + end "rem"; + + function "rem" (i1: Multi_int; i2: Basic_int) return Multi_int is + begin return i1 rem Multi(i2); end "rem"; + + function "rem" (i1: Multi_int; i2: Basic_int) return Basic_int is + q: Multi_int(i1.last_used + 1); + r: Basic_int; + begin + Div_Rem(i1,i2, q,r); + return r; + end "rem"; + + function "mod" (i1,i2: Multi_int) return Multi_int is + q: Multi_int(Max(0,i1.last_used - i2.last_used + 1)); + r: Multi_int(Max(i1.last_used,i2.last_used) + 2); + begin + -- Ada RM, 4.5.5 Multiplying Operators + -- (8) + -- The signed integer modulus operator is defined such that + -- the result of A mod B has the sign of B and an absolute value + -- less than the absolute value of B; in addition, for some signed + -- integer value N, this result satisfies the relation: + -- (9) A = B*N + (A mod B) + + Div_Rem(i1,i2, q,r); + if r.zero or else i2.neg = r.neg then -- (A rem B) est nul ou + return r; -- a le meme signe que B, donc (A mod B) = (A rem B) + else -- signe opposes + return i2+r; -- alors (B + (A rem B)) est le bon candidat + end if; + end "mod"; + + function "mod" (i1: Multi_int; i2: Basic_int) return Multi_int is + begin return i1 mod Multi(i2); end "mod"; + + function "mod" (i1: Multi_int; i2: Basic_int) return Basic_int is + r: constant Basic_int:= i1 rem i2; + begin + if r=0 or else (i2<0) = (r<0) then -- (A rem B) est nul ou + return r; -- a le meme signe que B, donc (A mod B) = (A rem B) + else -- signe opposes + return i2+r; -- alors (B + (A rem B)) est le bon candidat + end if; + end "mod"; + +----- End of DIVISION part ------ + +----- Begin of POWER part ------- + + procedure Power (i: Multi_int; n: Natural; ipn: out Multi_int) is + max_ipn_last: Index_int; -- 17-Feb-2002 + begin + if i.zero then + if n=0 then + raise Zero_power_zero; + else + -- The 0**n = 0 case (17-Feb-2002). + ipn.zero:= True; -- 4-Nov-2006, was: Fill( ipn, Multi(0) ); + return; + end if; + end if; + + max_ipn_last:= ((1+i.last_used) * Index_int(n)-1)+2; + if ipn.n < max_ipn_last then + raise Result_undersized; + end if; + + case n is + when 0 => Fill( ipn, one ); -- the i**0 = 1 case + when 1 => Fill( ipn, i); -- the i**1 = i case + when others => + declare + nn: Natural:= n-1; + i0, ii: Multi_int( max_ipn_last ); + begin + Fill(i0, i); + Fill(ii, i0 ); + + while nn > 0 loop + if nn mod 2 = 0 then -- x^(2 c) = (x^2) ^c + Mult(i0,i0, i0); + nn:= nn / 2; + else + Mult(i0,ii, ii); + nn:= nn - 1; + end if; + end loop; + Fill( ipn, ii); + end; + end case; + end Power; + + function "**" (i: Multi_int; n: Natural) return Multi_int is + ipn: Multi_int( (1+i.last_used) * Index_int(n)+2 ); + begin + Power(i,n,ipn); + return ipn; + end "**"; + + procedure Power (i: Multi_int; n: Multi_int; ipn: out Multi_int; + modulo: Multi_int) is + max_ipn_last: Index_int; + begin + if i.zero then + if n.zero then + raise Zero_power_zero; + else + -- The 0**n = 0 case (17-Feb-2002). + ipn.zero:= True; -- 4-Nov-2006, was: Fill( ipn, Multi(0) ); + return; + end if; + end if; + + if n.neg then + raise Power_negative; + end if; + + if modulo.zero or else (i.neg or modulo.neg) then + raise Power_modulo_non_positive; + end if; + + max_ipn_last:= 2*modulo.last_used+2; + if ipn.n < max_ipn_last then + raise Result_undersized; + end if; + + if n.zero then + Fill( ipn, one ); -- the i**0 = 1 case + elsif Equal( n, one ) then + Fill( ipn, i); -- the i**1 = i case + else + declare + nn: Multi_int(n.n):= n; + i0, ii, dummy: Multi_int( max_ipn_last ); + dummy_b: Basic_int; + begin + Subtract( nn, one, nn ); -- nn:= nn - 1; + Fill(i0, i); + Fill(ii, i0 ); + + while nn > 0 loop + if Even(nn) then -- x^(2 c) = (x^2) ^c + Mult(i0,i0, i0); + Div_Rem(nn, 2, nn, dummy_b); -- nn:= nn/2 + Div_Rem(i0,modulo,dummy,i0); -- i0:= i0 mod modulo + else + Mult(i0,ii, ii); + Subtract( nn, one, nn ); -- nn:= nn - 1; + Div_Rem(ii,modulo,dummy,ii); -- ii:= ii mod modulo + end if; + end loop; + Fill( ipn, ii); + end; + end if; + end Power; + +----- End of POWER part --------- + +----- Comparisons + + function Equal (i1,i2: Multi_int) return Boolean is + begin + if i1.zero and then i2.zero then + return True; + end if; + + if i1.zero = i2.zero and then + i1.neg = i2.neg and then + i1.last_used = i2.last_used then + return i1.blk(0..i1.last_used) = i2.blk(0..i2.last_used); + else + return False; + end if; + end Equal; + + function Equal (i1: Multi_int; i2:Basic_int) return Boolean is + begin + return Equal( i1, Multi(i2) ); + end Equal; + + function ">" (i1,i2: Multi_int) return Boolean is + begin + -- (1) Cas \'evident o\`u: i1 <= i2 + if (i1.zero or i1.neg) and then -- i1 <= 0 et + (i2.zero or not i2.neg) then -- i2 >= 0 + return False; + end if; + + -- (2.1) Cas \'evident o\`u: i1 > i2 + if ((not i1.zero) and not i1.neg) and then -- i1 > 0 et + (i2.zero or i2.neg) then -- i2 <= 0 + return True; + end if; + + -- (2.2) Cas \'evident o\`u: i1 > i2 + if (i1.zero or not i1.neg) and then -- i1 >= 0 et + ((not i2.zero) and i2.neg) then -- i2 < 0 + return True; + end if; + + -- Cas faciles resolus: + -- i1 > i2 - 0 + + ------------------- + -- - # F F + -- 0 T F F + -- + T T # + + -- On a les cas avec "#", o\`u i1 et i2 ont le meme signe + + if i1.neg then + return not (Compare_absolute (i1,i2) = greater); + else + return (Compare_absolute (i1,i2) = greater); + end if; + + end ">"; + + function ">" (i1: Multi_int; i2:Basic_int) return Boolean is + begin + return i1 > Multi(i2); + end ">"; + + function "<" (i1,i2: Multi_int) return Boolean is + begin return i2>i1; end "<"; + + function "<" (i1: Multi_int; i2:Basic_int) return Boolean is + begin + return i1 < Multi(i2); + end "<"; + + function ">=" (i1,i2: Multi_int) return Boolean is + begin return not (i2>i1); end ">="; + + function ">=" (i1: Multi_int; i2:Basic_int) return Boolean is + begin + return i1 >= Multi(i2); + end ">="; + + function "<=" (i1,i2: Multi_int) return Boolean is + begin return not (i1>i2); end "<="; + + function "<=" (i1: Multi_int; i2:Basic_int) return Boolean is + begin + return i1 <= Multi(i2); + end "<="; + +end Multi_precision_integers; diff --git a/src/multi_precision_integers.ads b/src/multi_precision_integers.ads new file mode 100644 index 0000000..7c8406a --- /dev/null +++ b/src/multi_precision_integers.ads @@ -0,0 +1,236 @@ +------------------------------------------------------------------------------ +-- File: multi_precision_integers.ads +-- +-- Description: Multiple precision integers package +-- +-- Date/version: Aug-2007: - No more generics (Long_Block_type, +-- Block_type,... always the largest possible +-- idea: J.C.) +-- - Fixed Basic(...) (based on J.C.'s remarks) +-- Nov-2006: - unsigned types for blocks +-- - a block uses 2 bits more +-- - Ada95+ only +-- Mar-2002: Bugs fixed related to zero field, division +-- Nov-1999: - procedures (no stack, less copies !) +-- - new data structure +-- Dec-1996: First version (operators only) +-- +-- Author: G. de Montmollin, Univ. Neuchatel +-- +-- Thanks to: Duncan Sands, Univ. Paris-Sud, CNRS +-- Jeffrey R. Carter +-- +-- Tested on: Intel 586 (32 bit) - Windows 98, NT4+ - GNAT 3.13p+ +-- Intel 586 (32 bit) - Windows 98, NT4+ - ObjectAda 7.2.1+ +-- Alpha-AXP (64 bit) - OpenVMS 7.1 - Compaq Ada +-- +-- Division algorithm adaptated from BigInt 1.0 library, +-- by Stephen Adams, that refers to +-- D. E. Knuth, the Art of computer programming +-- volume 2, "Seminumerical Algorithms" +-- section 4.3.1, "Multiple-Precision Arithmetic" +-- +------------------------------------------------------------------------------ + +with System; + +package Multi_precision_integers is + + -- Integers for array indexing -- + + subtype Index_int is Integer; + + -- THE multi-precision integer type -- + + type Multi_int (n: Index_int) is private; + + -- Integer type for small values -- + + subtype Basic_int is Integer; -- the "normal" signed integer + + ---------------------------------------------------------------- + -- Debug mode: checks results of arithmetic operations and -- + -- Multi_int variables' integrity. -- + -- CAUTION: Debug = True reduces monstruously the performance -- + ---------------------------------------------------------------- + + Debug : constant Boolean:= False; + + --------------------------------------------- + ----- Informations, conversions, filling ---- + --------------------------------------------- + + -- Convert Basic_int to Multi_int + function Multi (small: Basic_int) return Multi_int; + + -- Convert Multi_int to Basic_int (when possible, else: Cannot_fit raised) + function Basic (large: Multi_int) return Basic_int; + + -- Fill an Multi_int of greater array dimension with a smaller one + procedure Fill (what: out Multi_int; with_smaller: Multi_int); + procedure Fill (what: out Multi_int; with_basic: Basic_int); + + -- Comparisons + function Equal (i1, i2: Multi_int) return Boolean; + function Equal (i1 : Multi_int; i2:Basic_int) return Boolean; + function ">" (i1, i2: Multi_int) return Boolean; + function ">" (i1 : Multi_int; i2:Basic_int) return Boolean; + function "<" (i1, i2: Multi_int) return Boolean; + function "<" (i1 : Multi_int; i2:Basic_int) return Boolean; + function ">=" (i1, i2: Multi_int) return Boolean; + function ">=" (i1 : Multi_int; i2:Basic_int) return Boolean; + function "<=" (i1, i2: Multi_int) return Boolean; + function "<=" (i1 : Multi_int; i2:Basic_int) return Boolean; + + -- Other informations + function Bits_per_block return Positive; + + --------------------------------------------------------------------------- + -------- Arithmetic operators. ---------- + -------- For speed, the "procedure" variants should be preferred ---------- + --------------------------------------------------------------------------- + + --------------------------- + ----- Unary operators ----- + --------------------------- + + procedure Opp (i: in out Multi_int); + function "+" (i : Multi_int) return Multi_int; + function "-" (i : Multi_int) return Multi_int; + + procedure Abso (i: in out Multi_int); + function "ABS" (i : Multi_int) return Multi_int; + + function Sign (i: Multi_int) return Basic_int; + function Even (i: Multi_int) return Boolean; + function Odd (i : Multi_int) return Boolean; + + ---------------------------- + ----- Binary operators ----- + ---------------------------- + + --------------------------- + -- Addition, subtraction -- + --------------------------- + + procedure Add (i1,i2: in Multi_int; i3: in out Multi_int); + + function "+" (i1, i2: Multi_int) return Multi_int; + function "+" (i1 : Multi_int; i2: Basic_int) return Multi_int; + function "+" (i1 : Basic_int; i2: Multi_int) return Multi_int; + + procedure Sub (i1, i2: in Multi_int; i3: in out Multi_int); + procedure Subtract (i1,i2: in Multi_int; i3: in out Multi_int) + renames Sub; + + function "-" (i1, i2: Multi_int) return Multi_int; + function "-" (i1 : Multi_int; i2: Basic_int) return Multi_int; + function "-" (i1 : Basic_int; i2: Multi_int) return Multi_int; + + -------------------- + -- Multiplication -- + -------------------- + + procedure Multiply (i1,i2: in Multi_int; i3: in out Multi_int); + procedure Mult (i1, i2: in Multi_int; i3: in out Multi_int) + renames Multiply; + + procedure Multiply (i1: in Multi_int; i2: Basic_int; i3: in out Multi_int); + procedure Mult (i1 : in Multi_int; i2: Basic_int; i3: in out Multi_int) + renames Multiply; + + function "*" (i1, i2: Multi_int) return Multi_int; + function "*" (i1 : Multi_int; i2: Basic_int) return Multi_int; + function "*" (i1 : Basic_int; i2: Multi_int) return Multi_int; + + ------------------------- + -- Division, Remainder -- + ------------------------- + + procedure Div_Rem (i1 : in Multi_int; i2: in Basic_int; + q : out Multi_int; r : out Basic_int); + procedure Div_Rem (i1, i2: in Multi_int; q,r: out Multi_int); + + procedure Divide (i1, i2: in Multi_int; q: out Multi_int); + + function "/" (i1, i2: Multi_int) return Multi_int; + function "/" (i1 : Multi_int; i2: Basic_int) return Multi_int; + function "Rem" (i1, i2: Multi_int) return Multi_int; + function "Rem" (i1 : Multi_int; i2: Basic_int) return Multi_int; + function "Rem" (i1 : Multi_int; i2: Basic_int) return Basic_int; + function "Mod" (i1, i2: Multi_int) return Multi_int; + function "Mod" (i1 : Multi_int; i2: Basic_int) return Multi_int; + function "Mod" (i1 : Multi_int; i2: Basic_int) return Basic_int; + + ----------- + -- Power -- + ----------- + + procedure Power (i : Multi_int; n: Natural; ipn: out Multi_int); + function "**" (i : Multi_int; n: Natural) return Multi_int; + -- + 26-Mar-2002 : + procedure Power (i : Multi_int; n: Multi_int; ipn: out Multi_int; + modulo : Multi_int); + + Cannot_fit, Empty_multi_int : exception; + + Array_too_small : exception; + + Result_undersized, + Quotient_undersized, + Remainder_undersized : exception; + + Division_by_zero : exception; + + Zero_power_zero, Power_negative : exception; + Power_modulo_non_positive : exception; + +private + + --> Long_Block_type is used for + and * of blocks. + -- It is by design + -- a/ the largest possible modular integer, and + -- b/ twice the size of Block_type defined below. + -- With the double of bits (2n) one can store m**2 + 2m without overflow + -- where m = 2**n - 1 is the largest value possible on n bits. + type Long_Block_type is mod System.Max_Binary_Modulus; + + --> Same size as Long_Block_type, but signed: + type Long_Block_type_signed is + range -2**(Long_Block_type'Size-1)..2**(Long_Block_type'Size-1)-1; + + --> Block_type: unsigned integer used to store a chunk of a Multi_int. + type Block_type is mod 2 ** (Long_Block_type'Size / 2); + + Block_type_bits: constant:= Block_type'Size; + + cardblock: constant:= 2 ** Block_type_bits; + -- Number of possible values + maxblock: constant:= Block_type'Last; + -- NB: GNAT (2006) optimizes out correctly the Block_type(l and maxblock_long) + -- to Block_type(l), the latter form being caught when range checks are on. + + type Block_array is array( Index_int range <> ) of Block_type; + -- 2006: was "of Basic_int" for obscure reasons... + + type Multi_int(n: Index_int) is record + blk: Block_array( 0..n ); -- the n blocks with ABSOLUTE value + neg: Boolean; -- negative flag + zero: Boolean:=True; -- zero flag (supercedes the other fields) + last_used: Index_int; -- the others blocks are supposed 0 + end record; + + -- NB the `zero' field supercedes EVERY other information (last_used, neg) + + ---------------------------------------------------------------------------- + -- Format of type Multi_int.blk: ( i_0, i_1, ..., i_k, *, ..., * ) -- + -- i_0..i_k are >=0 ; others (*) are treated as 0 -- + ---------------------------------------------------------------------------- + + -- Some internal procedures use by check: + + procedure Multiply_internal_copy_export(i1,i2: in Multi_int; i3: in out Multi_int); + + procedure Div_Rem_internal_both_export(i1,i2: in Multi_int; q,r: in out Multi_int); + +end Multi_precision_integers; diff --git a/src/rationals.adb b/src/rationals.adb index 62fe9b9..bc54106 100644 --- a/src/rationals.adb +++ b/src/rationals.adb @@ -1,28 +1,34 @@ with Ada.Strings.Fixed; +with Multi_Precision_Integers.IO; +use Multi_Precision_Integers.IO; package body Rationals is function Reduce - (Numerator, Denominator : in Big_Unsigned) + (Numerator, Denominator : in Multi_Int) return Fraction is - A : Big_Unsigned := Numerator; - B : Big_Unsigned := Denominator; - Temp : Big_Unsigned; + A, B, Temp : Multi_Int (M_Size); + Ret_N, Ret_D : Multi_Int (M_Size); begin + Fill (A, Numerator); + Fill (B, Denominator); + -- Euclid's algorithm loop Temp := A; A := B; - B := Temp mod B; - exit when B = 0; + Fill (B, Temp mod B); + exit when Equal (B, 0); end loop; - return (Num => Numerator / A, - Den => Denominator / A); + + Fill (Ret_N, Numerator / A); + Fill (Ret_D, Denominator / A); + return (Num => Ret_N, Den => Ret_D); end Reduce; @@ -43,7 +49,7 @@ package body Rationals is return Fraction is begin return Reduce - (Left.Num + Left.Den * Utils.To_Big_Unsigned (Word (Right)), + (Left.Num + Left.Den * Multi (Right), Left.Den); end "+"; @@ -53,7 +59,7 @@ package body Rationals is return Fraction is begin return Reduce - (Utils.To_Big_Unsigned (Word (Left)) * Right.Den + Right.Num, + (Multi (Left) * Right.Den + Right.Num, Right.Den); end "+"; @@ -75,7 +81,7 @@ package body Rationals is return Fraction is begin return Reduce - (Left.Num - Left.Den * Utils.To_Big_Unsigned (Word (Right)), + (Left.Num - Left.Den * Multi (Right), Left.Den); end "-"; @@ -85,7 +91,7 @@ package body Rationals is return Fraction is begin return Reduce - (Utils.To_Big_Unsigned (Word (Left)) * Right.Den - Right.Num, + (Multi (Left) * Right.Den - Right.Num, Right.Den); end "-"; @@ -117,7 +123,7 @@ package body Rationals is return Fraction is begin return Reduce - (Left.Num * Utils.To_Big_Unsigned (Word (Right)), + (Left.Num * Multi (Right), Left.Den); end "*"; @@ -127,7 +133,7 @@ package body Rationals is return Fraction is begin return Reduce - (Utils.To_Big_Unsigned (Word (Left)) * Right.Num, + (Multi (Left) * Right.Num, Right.Den); end "*"; @@ -150,7 +156,7 @@ package body Rationals is begin return Reduce (Left.Num, - Left.Den * Utils.To_Big_Unsigned (Word (Right))); + Left.Den * Multi (Right)); end "/"; function "/" @@ -160,14 +166,14 @@ package body Rationals is begin return Reduce (Right.Num, - Utils.To_Big_Unsigned (Word (Left)) * Right.Den); + Multi (Left) * Right.Den); end "/"; function "/" (Left, Right : in Integer) return Fraction is begin - return Reduce (Utils.To_Big_Unsigned (Word (Left)), Utils.To_Big_Unsigned (Word (Right))); + return Reduce (Multi (Left), Multi (Right)); end "/"; @@ -177,8 +183,8 @@ package body Rationals is (Left, Right : in Fraction) return Boolean is begin - return Left.Num = Right.Num and - Left.Den = Right.Den; + return Equal (Left.Num, Right.Num) and + Equal (Left.Den, Right.Den); end "="; function "=" @@ -186,7 +192,7 @@ package body Rationals is Right : in Integer) return Boolean is begin - return Left.Num = Utils.To_Big_Unsigned (Word (Right)) and Left.Den = 1; + return Equal (Left.Num, Right) and Equal (Left.Den, 1); end "="; function "=" @@ -194,7 +200,7 @@ package body Rationals is Right : in Fraction) return Boolean is begin - return Utils.To_Big_Unsigned (Word (Left)) = Right.Num and Right.Den = 1; + return Equal (Right.Num, Left) and Equal (Right.Den, 1); end "="; @@ -212,7 +218,7 @@ package body Rationals is Right : in Integer) return Boolean is begin - return Left.Num <= Left.Den * Utils.To_Big_Unsigned (Word (Right)); + return Left.Num <= Left.Den * Multi (Right); end "<="; function "<=" @@ -220,7 +226,7 @@ package body Rationals is Right : in Fraction) return Boolean is begin - return Utils.To_Big_Unsigned (Word (Left)) * Right.Den <= Right.Num; + return Multi (Left) * Right.Den <= Right.Num; end "<="; @@ -238,7 +244,7 @@ package body Rationals is Right : in Integer) return Boolean is begin - return Left.Num < Left.Den * Utils.To_Big_Unsigned (Word (Right)); + return Left.Num < Left.Den * Multi (Right); end "<"; function "<" @@ -246,7 +252,7 @@ package body Rationals is Right : in Fraction) return Boolean is begin - return Utils.To_Big_Unsigned (Word (Left)) * Right.Den < Right.Num; + return Multi (Left) * Right.Den < Right.Num; end "<"; @@ -264,7 +270,7 @@ package body Rationals is Right : in Integer) return Boolean is begin - return Left.Num >= Left.Den * Utils.To_Big_Unsigned (Word (Right)); + return Left.Num >= Left.Den * Multi (Right); end ">="; function ">=" @@ -272,7 +278,7 @@ package body Rationals is Right : in Fraction) return Boolean is begin - return Utils.To_Big_Unsigned (Word (Left)) * Right.Den >= Right.Num; + return Multi (Left) * Right.Den >= Right.Num; end ">="; @@ -290,7 +296,7 @@ package body Rationals is Right : in Integer) return Boolean is begin - return Left.Num > Left.Den * Utils.To_Big_Unsigned (Word (Right)); + return Left.Num > Left.Den * Multi (Right); end ">"; function ">" @@ -298,7 +304,7 @@ package body Rationals is Right : in Fraction) return Boolean is begin - return Utils.To_Big_Unsigned (Word (Left)) * Right.Den > Right.Num; + return Multi (Left) * Right.Den > Right.Num; end ">"; @@ -308,31 +314,31 @@ package body Rationals is (Item : in Fraction) return Integer is begin - return Integer (Utils.To_Words (Item.Num)(1)); + return Basic (Item.Num); end Numerator; function Denominator (Item : in Fraction) return Integer is begin - return Integer (Utils.To_Words (Item.Den)(1)); + return Basic (Item.Den); end Denominator; function Floor (Item : in Fraction) return Integer is begin - return Integer (Utils.To_Words (Item.Num / Item.Den)(0)); + return Basic (Item.Num / Item.Den); end Floor; function Ceiling (Item : in Fraction) return Integer is begin - if Item.Num mod Item.Den = 0 then - return Integer (Utils.To_Words (Item.Num / Item.Den)(1)); + if Equal (Item.Num mod Item.Den, 0) then + return Basic (Item.Num / Item.Den); else - return 1 + Integer (Utils.To_Words (Item.Num / Item.Den)(1)); + return 1 + Basic (Item.Num / Item.Den); end if; end Ceiling; @@ -341,9 +347,9 @@ package body Rationals is return Integer is begin if Item.Num mod Item.Den >= Item.Den / 2 then - return 1 + Integer (Utils.To_Words (Item.Num / Item.Den)(1)); + return 1 + Basic (Item.Num / Item.Den); else - return Integer (Utils.To_Words (Item.Num / Item.Den)(1)); + return Basic (Item.Num / Item.Den); end if; end Round; @@ -354,8 +360,7 @@ package body Rationals is (Item : in Fraction) return String is begin - return Utils.To_String (Item.Num) & '/' & - Utils.To_String (Item.Den); + return Str (Item.Num) & '/' & Str (Item.Den); end Image; function Value @@ -369,7 +374,7 @@ package body Rationals is S := Index (Item, "/"); A := Integer'Value (Item (Item'First .. S - 1)); B := Integer'Value (Item (S + 1 .. Item'Last)); - return Reduce (Utils.To_Big_Unsigned (Word (A)), Utils.To_Big_Unsigned (Word (B))); + return Reduce (Multi (A), Multi (B)); end Value; diff --git a/src/rationals.ads b/src/rationals.ads index dfa5897..1f3de5f 100644 --- a/src/rationals.ads +++ b/src/rationals.ads @@ -1,6 +1,6 @@ -private with Crypto.Types.Big_Numbers; +private with Multi_Precision_Integers; package Rationals is @@ -210,14 +210,15 @@ package Rationals is private - package Bignum is new Crypto.Types.Big_Numbers (Size => 128); - use Crypto.Types; - use Bignum; + use Multi_Precision_Integers; + + + M_Size : constant Basic_Int := 4; type Fraction is record - Num : Big_Unsigned := Big_Unsigned_Zero; - Den : Big_Unsigned := Big_Unsigned_One; + Num : Multi_Int (M_Size); + Den : Multi_Int (M_Size); end record; diff --git a/src/stv.adb b/src/stv.adb index 4f8ef5a..10020e6 100644 --- a/src/stv.adb +++ b/src/stv.adb @@ -255,12 +255,12 @@ begin Finish_Time := Simple_Time.Now; Log_Msg := SU.To_Unbounded_String ("Finished election count at " & Simple_Time.To_String (Finish_Time) & ASCII.LF & - Duration'Image (Finish_Time - Start_Time) & " seconds elapsed." & ASCII.LF); + Duration'Image (Finish_Time - Start_Time) & " seconds elapsed."); Open (Log_File, Append_File, SU.To_String (Main_Log)); Put_Line (Log_File, SU.To_String (Log_Msg)); Close (Log_File); if Verbose then - Put_Line (Standard_Error, SU.To_String (Log_Msg)); + Put_Line (Standard_Error, ASCII.LF & SU.To_String (Log_Msg)); end if; -- cgit