From 7cfc4e5146be5666419451bdd516f1f3f264d24a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 25 Jan 2015 14:42:51 +0100 Subject: Imported Upstream version 8.5~beta1+dfsg --- test-suite/Makefile | 224 +- test-suite/bench/lists-100.v | 2 +- test-suite/bench/lists_100.v | 2 +- test-suite/bugs/2428.v | 10 + test-suite/bugs/closed/1100.v | 12 + test-suite/bugs/closed/121.v | 17 + test-suite/bugs/closed/1243.v | 12 + test-suite/bugs/closed/1302.v | 22 + test-suite/bugs/closed/1322.v | 24 + test-suite/bugs/closed/1411.v | 35 + test-suite/bugs/closed/1414.v | 40 + test-suite/bugs/closed/1416.v | 30 + test-suite/bugs/closed/1419.v | 8 + test-suite/bugs/closed/1425.v | 19 + test-suite/bugs/closed/1446.v | 20 + test-suite/bugs/closed/1448.v | 28 + test-suite/bugs/closed/1477.v | 18 + test-suite/bugs/closed/1483.v | 10 + test-suite/bugs/closed/1507.v | 120 + test-suite/bugs/closed/1568.v | 13 + test-suite/bugs/closed/1576.v | 38 + test-suite/bugs/closed/1582.v | 15 + test-suite/bugs/closed/1604.v | 7 + test-suite/bugs/closed/1614.v | 21 + test-suite/bugs/closed/1618.v | 23 + test-suite/bugs/closed/1634.v | 24 + test-suite/bugs/closed/1643.v | 20 + test-suite/bugs/closed/1680.v | 9 + test-suite/bugs/closed/1683.v | 42 + test-suite/bugs/closed/1696.v | 16 + test-suite/bugs/closed/1703.v | 8 + test-suite/bugs/closed/1704.v | 17 + test-suite/bugs/closed/1711.v | 34 + test-suite/bugs/closed/1718.v | 9 + test-suite/bugs/closed/1738.v | 30 + test-suite/bugs/closed/1740.v | 23 + test-suite/bugs/closed/1754.v | 24 + test-suite/bugs/closed/1773.v | 9 + test-suite/bugs/closed/1774.v | 18 + test-suite/bugs/closed/1775.v | 39 + test-suite/bugs/closed/1776.v | 22 + test-suite/bugs/closed/1779.v | 25 + test-suite/bugs/closed/1784.v | 101 + test-suite/bugs/closed/1791.v | 38 + test-suite/bugs/closed/1834.v | 174 ++ test-suite/bugs/closed/1844.v | 217 ++ test-suite/bugs/closed/1865.v | 18 + test-suite/bugs/closed/1891.v | 13 + test-suite/bugs/closed/1898.v | 6 + test-suite/bugs/closed/1900.v | 8 + test-suite/bugs/closed/1901.v | 11 + test-suite/bugs/closed/1905.v | 13 + test-suite/bugs/closed/1907.v | 7 + test-suite/bugs/closed/1912.v | 6 + test-suite/bugs/closed/1915.v | 6 + test-suite/bugs/closed/1918.v | 376 +++ test-suite/bugs/closed/1925.v | 22 + test-suite/bugs/closed/1931.v | 29 + test-suite/bugs/closed/1935.v | 21 + test-suite/bugs/closed/1939.v | 19 + test-suite/bugs/closed/1944.v | 9 + test-suite/bugs/closed/1951.v | 63 + test-suite/bugs/closed/1962.v | 55 + test-suite/bugs/closed/1963.v | 19 + test-suite/bugs/closed/1977.v | 4 + test-suite/bugs/closed/1981.v | 5 + test-suite/bugs/closed/2001.v | 22 + test-suite/bugs/closed/2006.v | 23 + test-suite/bugs/closed/2017.v | 15 + test-suite/bugs/closed/2021.v | 23 + test-suite/bugs/closed/2027.v | 11 + test-suite/bugs/closed/2083.v | 27 + test-suite/bugs/closed/2089.v | 17 + test-suite/bugs/closed/2095.v | 19 + test-suite/bugs/closed/2108.v | 22 + test-suite/bugs/closed/2117.v | 56 + test-suite/bugs/closed/2123.v | 11 + test-suite/bugs/closed/2127.v | 8 + test-suite/bugs/closed/2135.v | 9 + test-suite/bugs/closed/2136.v | 61 + test-suite/bugs/closed/2137.v | 52 + test-suite/bugs/closed/2139.v | 24 + test-suite/bugs/closed/2141.v | 14 + test-suite/bugs/closed/2145.v | 20 + test-suite/bugs/closed/2149.v | 7 + test-suite/bugs/closed/2164.v | 334 +++ test-suite/bugs/closed/2181.v | 3 + test-suite/bugs/closed/2193.v | 31 + test-suite/bugs/closed/2230.v | 6 + test-suite/bugs/closed/2231.v | 3 + test-suite/bugs/closed/2244.v | 19 + test-suite/bugs/closed/2250.v | 3 + test-suite/bugs/closed/2251.v | 6 + test-suite/bugs/closed/2255.v | 21 + test-suite/bugs/closed/2262.v | 11 + test-suite/bugs/closed/2281.v | 50 + test-suite/bugs/closed/2295.v | 11 + test-suite/bugs/closed/2299.v | 13 + test-suite/bugs/closed/2300.v | 15 + test-suite/bugs/closed/2303.v | 4 + test-suite/bugs/closed/2304.v | 4 + test-suite/bugs/closed/2307.v | 3 + test-suite/bugs/closed/2310.v | 17 + test-suite/bugs/closed/2320.v | 14 + test-suite/bugs/closed/2342.v | 8 + test-suite/bugs/closed/2347.v | 10 + test-suite/bugs/closed/2350.v | 6 + test-suite/bugs/closed/2353.v | 12 + test-suite/bugs/closed/2360.v | 13 + test-suite/bugs/closed/2362.v | 38 + test-suite/bugs/closed/2375.v | 18 + test-suite/bugs/closed/2378.v | 611 ++++ test-suite/bugs/closed/2388.v | 10 + test-suite/bugs/closed/2393.v | 13 + test-suite/bugs/closed/2404.v | 46 + test-suite/bugs/closed/2406.v | 6 + test-suite/bugs/closed/2447.v | 7 + test-suite/bugs/closed/2456.v | 53 + test-suite/bugs/closed/2464.v | 39 + test-suite/bugs/closed/2467.v | 49 + test-suite/bugs/closed/2473.v | 39 + test-suite/bugs/closed/2586.v | 6 + test-suite/bugs/closed/2603.v | 33 + test-suite/bugs/closed/2608.v | 34 + test-suite/bugs/closed/2613.v | 17 + test-suite/bugs/closed/2615.v | 16 + test-suite/bugs/closed/2616.v | 7 + test-suite/bugs/closed/2629.v | 22 + test-suite/bugs/closed/2640.v | 17 + test-suite/bugs/closed/2667.v | 11 + test-suite/bugs/closed/2668.v | 6 + test-suite/bugs/closed/2670.v | 21 + test-suite/bugs/closed/2680.v | 17 + test-suite/bugs/closed/2713.v | 17 + test-suite/bugs/closed/2729.v | 115 + test-suite/bugs/closed/2732.v | 19 + test-suite/bugs/closed/2733.v | 28 + test-suite/bugs/closed/2734.v | 15 + test-suite/bugs/closed/2750.v | 23 + test-suite/bugs/closed/2810.v | 10 + test-suite/bugs/closed/2817.v | 9 + test-suite/bugs/closed/2818.v | 11 + test-suite/bugs/closed/2828.v | 4 + test-suite/bugs/closed/2830.v | 226 ++ test-suite/bugs/closed/2834.v | 4 + test-suite/bugs/closed/2836.v | 39 + test-suite/bugs/closed/2837.v | 15 + test-suite/bugs/closed/2839.v | 10 + test-suite/bugs/closed/2846.v | 3 + test-suite/bugs/closed/2848.v | 9 + test-suite/bugs/closed/2850.v | 2 + test-suite/bugs/closed/2854.v | 7 + test-suite/bugs/closed/2876.v | 11 + test-suite/bugs/closed/2883.v | 34 + test-suite/bugs/closed/2900.v | 28 + test-suite/bugs/closed/2920.v | 2 + test-suite/bugs/closed/2923.v | 12 + test-suite/bugs/closed/2928.v | 11 + test-suite/bugs/closed/2930.v | 12 + test-suite/bugs/closed/2945.v | 5 + test-suite/bugs/closed/2966.v | 79 + test-suite/bugs/closed/2969.v | 25 + test-suite/bugs/closed/2981.v | 15 + test-suite/bugs/closed/2983.v | 8 + test-suite/bugs/closed/2990.v | 8 + test-suite/bugs/closed/2994.v | 2 + test-suite/bugs/closed/2995.v | 9 + test-suite/bugs/closed/2996.v | 30 + test-suite/bugs/closed/3000.v | 2 + test-suite/bugs/closed/3001.v | 21 + test-suite/bugs/closed/3004.v | 7 + test-suite/bugs/closed/3008.v | 29 + test-suite/bugs/closed/3010b.v | 5 + test-suite/bugs/closed/3016.v | 4 + test-suite/bugs/closed/3017.v | 6 + test-suite/bugs/closed/3022.v | 8 + test-suite/bugs/closed/3023.v | 8 +- test-suite/bugs/closed/3036.v | 169 ++ test-suite/bugs/closed/3037.v | 11 + test-suite/bugs/closed/3043.v | 4 + test-suite/bugs/closed/3045.v | 34 + test-suite/bugs/closed/3050.v | 7 + test-suite/bugs/closed/3054.v | 10 + test-suite/bugs/closed/3062.v | 5 + test-suite/bugs/closed/3068.v | 63 + test-suite/bugs/closed/3088.v | 12 + test-suite/bugs/closed/3093.v | 6 + test-suite/bugs/closed/3142.v | 9 + test-suite/bugs/closed/3164.v | 49 + test-suite/bugs/closed/3188.v | 22 + test-suite/bugs/closed/3205.v | 26 + test-suite/bugs/closed/3212.v | 10 + test-suite/bugs/closed/3217.v | 36 + test-suite/bugs/closed/3228.v | 7 + test-suite/bugs/closed/3242.v | 2 + test-suite/bugs/closed/3251.v | 13 + test-suite/bugs/closed/3258.v | 35 + test-suite/bugs/closed/3259.v | 21 + test-suite/bugs/closed/3260.v | 7 + test-suite/bugs/closed/3262.v | 78 + test-suite/bugs/closed/3264.v | 45 + test-suite/bugs/closed/3265.v | 6 + test-suite/bugs/closed/3266.v | 3 + test-suite/bugs/closed/3267.v | 36 + test-suite/bugs/closed/328.v | 40 + test-suite/bugs/closed/3281.v | 5 + test-suite/bugs/closed/3282.v | 7 + test-suite/bugs/closed/3284.v | 23 + test-suite/bugs/closed/3285.v | 7 + test-suite/bugs/closed/3286.v | 41 + test-suite/bugs/closed/3287.v | 20 + test-suite/bugs/closed/3289.v | 27 + test-suite/bugs/closed/329.v | 100 + test-suite/bugs/closed/3291.v | 9 + test-suite/bugs/closed/3294.v | 6 + test-suite/bugs/closed/3297.v | 12 + test-suite/bugs/closed/3300.v | 7 + test-suite/bugs/closed/3305.v | 13 + test-suite/bugs/closed/3306.v | 12 + test-suite/bugs/closed/3309.v | 326 +++ test-suite/bugs/closed/331.v | 20 + test-suite/bugs/closed/3310.v | 11 + test-suite/bugs/closed/3314.v | 147 + test-suite/bugs/closed/3315.v | 37 + test-suite/bugs/closed/3317.v | 94 + test-suite/bugs/closed/3319.v | 25 + test-suite/bugs/closed/3321.v | 18 + test-suite/bugs/closed/3322.v | 23 + test-suite/bugs/closed/3323.v | 77 + test-suite/bugs/closed/3324.v | 47 + test-suite/bugs/closed/3325.v | 48 + test-suite/bugs/closed/3326.v | 19 + test-suite/bugs/closed/3329.v | 93 + test-suite/bugs/closed/3330.v | 1110 +++++++ test-suite/bugs/closed/3331.v | 31 + test-suite/bugs/closed/3332.v | 6 + test-suite/bugs/closed/3336.v | 9 + test-suite/bugs/closed/3337.v | 4 + test-suite/bugs/closed/3338.v | 4 + test-suite/bugs/closed/3344.v | 58 + test-suite/bugs/closed/3346.v | 4 + test-suite/bugs/closed/3347.v | 39 + test-suite/bugs/closed/3348.v | 6 + test-suite/bugs/closed/335.v | 5 + test-suite/bugs/closed/3350.v | 120 + test-suite/bugs/closed/3352.v | 34 + test-suite/bugs/closed/3354.v | 12 + test-suite/bugs/closed/3355.v | 6 + test-suite/bugs/closed/3368.v | 16 + test-suite/bugs/closed/3372.v | 7 + test-suite/bugs/closed/3373.v | 33 + test-suite/bugs/closed/3374.v | 51 + test-suite/bugs/closed/3375.v | 48 + test-suite/bugs/closed/3377.v | 17 + test-suite/bugs/closed/3382.v | 63 + test-suite/bugs/closed/3386.v | 16 + test-suite/bugs/closed/3387.v | 21 + test-suite/bugs/closed/3388.v | 57 + test-suite/bugs/closed/3390.v | 9 + test-suite/bugs/closed/3392.v | 40 + test-suite/bugs/closed/3393.v | 152 + test-suite/bugs/closed/3402.v | 7 + test-suite/bugs/closed/3408.v | 163 ++ test-suite/bugs/closed/3416.v | 12 + test-suite/bugs/closed/3417.v | 7 + test-suite/bugs/closed/3422.v | 208 ++ test-suite/bugs/closed/3424.v | 23 + test-suite/bugs/closed/3427.v | 195 ++ test-suite/bugs/closed/3428.v | 35 + test-suite/bugs/closed/3439.v | 43 + test-suite/bugs/closed/3453.v | 10 + test-suite/bugs/closed/3454.v | 63 + test-suite/bugs/closed/3469.v | 29 + test-suite/bugs/closed/3477.v | 9 + test-suite/bugs/closed/348.v | 13 + test-suite/bugs/closed/3480.v | 47 + test-suite/bugs/closed/3481.v | 70 + test-suite/bugs/closed/3482.v | 11 + test-suite/bugs/closed/3483.v | 5 + test-suite/bugs/closed/3484.v | 30 + test-suite/bugs/closed/3485.v | 133 + test-suite/bugs/closed/3487.v | 8 + test-suite/bugs/closed/3505.v | 44 + test-suite/bugs/closed/3520.v | 12 + test-suite/bugs/closed/3531.v | 53 + test-suite/bugs/closed/3537.v | 12 + test-suite/bugs/closed/3539.v | 66 + test-suite/bugs/closed/3542.v | 6 + test-suite/bugs/closed/3546.v | 17 + test-suite/bugs/closed/3559.v | 86 + test-suite/bugs/closed/3561.v | 23 + test-suite/bugs/closed/3562.v | 6 + test-suite/bugs/closed/3563.v | 38 + test-suite/bugs/closed/3566.v | 22 + test-suite/bugs/closed/3567.v | 68 + test-suite/bugs/closed/3584.v | 16 + test-suite/bugs/closed/3593.v | 10 + test-suite/bugs/closed/3594.v | 51 + test-suite/bugs/closed/3596.v | 18 + test-suite/bugs/closed/3616.v | 3 + test-suite/bugs/closed/3618.v | 103 + test-suite/bugs/closed/3623.v | 4 + test-suite/bugs/closed/3624.v | 11 + test-suite/bugs/closed/3625.v | 11 + test-suite/bugs/closed/3628.v | 9 + test-suite/bugs/closed/3633.v | 10 + test-suite/bugs/closed/3637.v | 11 + test-suite/bugs/closed/3638.v | 25 + test-suite/bugs/closed/3640.v | 31 + test-suite/bugs/closed/3641.v | 21 + test-suite/bugs/closed/3647.v | 652 +++++ test-suite/bugs/closed/3648.v | 83 + test-suite/bugs/closed/3652.v | 101 + test-suite/bugs/closed/3653.v | 12 + test-suite/bugs/closed/3654.v | 7 + test-suite/bugs/closed/3656.v | 53 + test-suite/bugs/closed/3657.v | 12 + test-suite/bugs/closed/3658.v | 74 + test-suite/bugs/closed/3660.v | 27 + test-suite/bugs/closed/3661.v | 88 + test-suite/bugs/closed/3662.v | 47 + test-suite/bugs/closed/3664.v | 23 + test-suite/bugs/closed/3665.v | 33 + test-suite/bugs/closed/3666.v | 50 + test-suite/bugs/closed/3667.v | 25 + test-suite/bugs/closed/3668.v | 53 + test-suite/bugs/closed/3670.v | 23 + test-suite/bugs/closed/3672.v | 27 + test-suite/bugs/closed/3675.v | 20 + test-suite/bugs/closed/3682.v | 5 + test-suite/bugs/closed/3684.v | 4 + test-suite/bugs/closed/3686.v | 62 + test-suite/bugs/closed/3692.v | 26 + test-suite/bugs/closed/3698.v | 25 + test-suite/bugs/closed/3699.v | 162 ++ test-suite/bugs/closed/3700.v | 84 + test-suite/bugs/closed/3709.v | 23 + test-suite/bugs/closed/3710.v | 48 + test-suite/bugs/closed/3723.v | 6 + test-suite/bugs/closed/3782.v | 63 + test-suite/bugs/closed/3788.v | 6 + test-suite/bugs/closed/3792.v | 4 + test-suite/bugs/closed/38.v | 22 + test-suite/bugs/closed/3804.v | 12 + test-suite/bugs/closed/3821.v | 2 + test-suite/bugs/closed/3828.v | 2 + test-suite/bugs/closed/3848.v | 21 + test-suite/bugs/closed/3854.v | 21 + test-suite/bugs/closed/3892.v | 8 + test-suite/bugs/closed/3895.v | 22 + test-suite/bugs/closed/3896.v | 4 + test-suite/bugs/closed/3899.v | 11 + test-suite/bugs/closed/545.v | 5 + test-suite/bugs/closed/808_2411.v | 27 + test-suite/bugs/closed/846.v | 213 ++ test-suite/bugs/closed/931.v | 7 + test-suite/bugs/closed/HoTT_coq_001.v | 5 + test-suite/bugs/closed/HoTT_coq_002.v | 33 + test-suite/bugs/closed/HoTT_coq_006.v | 99 + test-suite/bugs/closed/HoTT_coq_007.v | 112 + test-suite/bugs/closed/HoTT_coq_010.v | 3 + test-suite/bugs/closed/HoTT_coq_012.v | 4 + test-suite/bugs/closed/HoTT_coq_013.v | 24 + test-suite/bugs/closed/HoTT_coq_014.v | 200 ++ test-suite/bugs/closed/HoTT_coq_016.v | 15 + test-suite/bugs/closed/HoTT_coq_020.v | 95 + test-suite/bugs/closed/HoTT_coq_023.v | 12 + test-suite/bugs/closed/HoTT_coq_025.v | 29 + test-suite/bugs/closed/HoTT_coq_027.v | 94 + test-suite/bugs/closed/HoTT_coq_028.v | 14 + test-suite/bugs/closed/HoTT_coq_029.v | 335 +++ test-suite/bugs/closed/HoTT_coq_030.v | 241 ++ test-suite/bugs/closed/HoTT_coq_032.v | 22 + test-suite/bugs/closed/HoTT_coq_034.v | 23 + test-suite/bugs/closed/HoTT_coq_035.v | 19 + test-suite/bugs/closed/HoTT_coq_036.v | 135 + test-suite/bugs/closed/HoTT_coq_037.v | 16 + test-suite/bugs/closed/HoTT_coq_041.v | 18 + test-suite/bugs/closed/HoTT_coq_042.v | 27 + test-suite/bugs/closed/HoTT_coq_043.v | 15 + test-suite/bugs/closed/HoTT_coq_044.v | 35 + test-suite/bugs/closed/HoTT_coq_045.v | 53 + test-suite/bugs/closed/HoTT_coq_047.v | 46 + test-suite/bugs/closed/HoTT_coq_048.v | 7 + test-suite/bugs/closed/HoTT_coq_049.v | 6 + test-suite/bugs/closed/HoTT_coq_050.v | 33 + test-suite/bugs/closed/HoTT_coq_052.v | 22 + test-suite/bugs/closed/HoTT_coq_053.v | 50 + test-suite/bugs/closed/HoTT_coq_054.v | 94 + test-suite/bugs/closed/HoTT_coq_055.v | 53 + test-suite/bugs/closed/HoTT_coq_056.v | 156 + test-suite/bugs/closed/HoTT_coq_057.v | 33 + test-suite/bugs/closed/HoTT_coq_058.v | 140 + test-suite/bugs/closed/HoTT_coq_059.v | 17 + test-suite/bugs/closed/HoTT_coq_061.v | 132 + test-suite/bugs/closed/HoTT_coq_062.v | 106 + test-suite/bugs/closed/HoTT_coq_063.v | 34 + test-suite/bugs/closed/HoTT_coq_064.v | 190 ++ test-suite/bugs/closed/HoTT_coq_067.v | 28 + test-suite/bugs/closed/HoTT_coq_068.v | 61 + test-suite/bugs/closed/HoTT_coq_071.v | 9 + test-suite/bugs/closed/HoTT_coq_074.v | 10 + test-suite/bugs/closed/HoTT_coq_077.v | 39 + test-suite/bugs/closed/HoTT_coq_078.v | 43 + test-suite/bugs/closed/HoTT_coq_079.v | 16 + test-suite/bugs/closed/HoTT_coq_080.v | 27 + test-suite/bugs/closed/HoTT_coq_081.v | 16 + test-suite/bugs/closed/HoTT_coq_082.v | 19 + test-suite/bugs/closed/HoTT_coq_083.v | 29 + test-suite/bugs/closed/HoTT_coq_084.v | 49 + test-suite/bugs/closed/HoTT_coq_085.v | 74 + test-suite/bugs/closed/HoTT_coq_087.v | 14 + test-suite/bugs/closed/HoTT_coq_088.v | 78 + test-suite/bugs/closed/HoTT_coq_089.v | 44 + test-suite/bugs/closed/HoTT_coq_090.v | 187 ++ test-suite/bugs/closed/HoTT_coq_091.v | 191 ++ test-suite/bugs/closed/HoTT_coq_093.v | 27 + test-suite/bugs/closed/HoTT_coq_094.v | 9 + test-suite/bugs/closed/HoTT_coq_097.v | 5 + test-suite/bugs/closed/HoTT_coq_098.v | 63 + test-suite/bugs/closed/HoTT_coq_099.v | 61 + test-suite/bugs/closed/HoTT_coq_100.v | 151 + test-suite/bugs/closed/HoTT_coq_101.v | 77 + test-suite/bugs/closed/HoTT_coq_102.v | 29 + test-suite/bugs/closed/HoTT_coq_103.v | 4 + test-suite/bugs/closed/HoTT_coq_104.v | 13 + test-suite/bugs/closed/HoTT_coq_105.v | 32 + test-suite/bugs/closed/HoTT_coq_107.v | 106 + test-suite/bugs/closed/HoTT_coq_108.v | 127 + test-suite/bugs/closed/HoTT_coq_110.v | 23 + test-suite/bugs/closed/HoTT_coq_111.v | 24 + test-suite/bugs/closed/HoTT_coq_112.v | 75 + test-suite/bugs/closed/HoTT_coq_113.v | 19 + test-suite/bugs/closed/HoTT_coq_114.v | 1 + test-suite/bugs/closed/HoTT_coq_115.v | 1 + test-suite/bugs/closed/HoTT_coq_116.v | 13 + test-suite/bugs/closed/HoTT_coq_117.v | 25 + test-suite/bugs/closed/HoTT_coq_118.v | 35 + test-suite/bugs/closed/HoTT_coq_121.v | 18 + test-suite/bugs/closed/HoTT_coq_122.v | 25 + test-suite/bugs/closed/HoTT_coq_123.v | 171 ++ test-suite/bugs/closed/HoTT_coq_124.v | 29 + test-suite/bugs/closed/shouldfail/1703.v | 7 - test-suite/bugs/closed/shouldfail/1898.v | 5 - test-suite/bugs/closed/shouldfail/1915.v | 6 - test-suite/bugs/closed/shouldfail/2006.v | 23 - test-suite/bugs/closed/shouldfail/2251.v | 5 - test-suite/bugs/closed/shouldfail/2406.v | 3 - test-suite/bugs/closed/shouldfail/2586.v | 5 - test-suite/bugs/closed/shouldsucceed/1041.v | 13 - test-suite/bugs/closed/shouldsucceed/1100.v | 12 - test-suite/bugs/closed/shouldsucceed/121.v | 17 - test-suite/bugs/closed/shouldsucceed/1243.v | 12 - test-suite/bugs/closed/shouldsucceed/1302.v | 22 - test-suite/bugs/closed/shouldsucceed/1322.v | 24 - test-suite/bugs/closed/shouldsucceed/1411.v | 35 - test-suite/bugs/closed/shouldsucceed/1414.v | 40 - test-suite/bugs/closed/shouldsucceed/1416.v | 30 - test-suite/bugs/closed/shouldsucceed/1419.v | 8 - test-suite/bugs/closed/shouldsucceed/1425.v | 19 - test-suite/bugs/closed/shouldsucceed/1446.v | 20 - test-suite/bugs/closed/shouldsucceed/1448.v | 28 - test-suite/bugs/closed/shouldsucceed/1477.v | 18 - test-suite/bugs/closed/shouldsucceed/1483.v | 10 - test-suite/bugs/closed/shouldsucceed/1507.v | 120 - test-suite/bugs/closed/shouldsucceed/1519.v | 14 - test-suite/bugs/closed/shouldsucceed/1568.v | 13 - test-suite/bugs/closed/shouldsucceed/1576.v | 38 - test-suite/bugs/closed/shouldsucceed/1582.v | 15 - test-suite/bugs/closed/shouldsucceed/1604.v | 7 - test-suite/bugs/closed/shouldsucceed/1614.v | 21 - test-suite/bugs/closed/shouldsucceed/1618.v | 23 - test-suite/bugs/closed/shouldsucceed/1634.v | 24 - test-suite/bugs/closed/shouldsucceed/1643.v | 20 - test-suite/bugs/closed/shouldsucceed/1680.v | 9 - test-suite/bugs/closed/shouldsucceed/1683.v | 42 - test-suite/bugs/closed/shouldsucceed/1696.v | 16 - test-suite/bugs/closed/shouldsucceed/1704.v | 17 - test-suite/bugs/closed/shouldsucceed/1711.v | 34 - test-suite/bugs/closed/shouldsucceed/1718.v | 9 - test-suite/bugs/closed/shouldsucceed/1738.v | 30 - test-suite/bugs/closed/shouldsucceed/1740.v | 23 - test-suite/bugs/closed/shouldsucceed/1754.v | 24 - test-suite/bugs/closed/shouldsucceed/1773.v | 9 - test-suite/bugs/closed/shouldsucceed/1774.v | 18 - test-suite/bugs/closed/shouldsucceed/1775.v | 39 - test-suite/bugs/closed/shouldsucceed/1776.v | 22 - test-suite/bugs/closed/shouldsucceed/1779.v | 25 - test-suite/bugs/closed/shouldsucceed/1784.v | 101 - test-suite/bugs/closed/shouldsucceed/1791.v | 38 - test-suite/bugs/closed/shouldsucceed/1834.v | 174 -- test-suite/bugs/closed/shouldsucceed/1844.v | 217 -- test-suite/bugs/closed/shouldsucceed/1865.v | 18 - test-suite/bugs/closed/shouldsucceed/1891.v | 13 - test-suite/bugs/closed/shouldsucceed/1900.v | 8 - test-suite/bugs/closed/shouldsucceed/1901.v | 11 - test-suite/bugs/closed/shouldsucceed/1905.v | 13 - test-suite/bugs/closed/shouldsucceed/1907.v | 7 - test-suite/bugs/closed/shouldsucceed/1912.v | 6 - test-suite/bugs/closed/shouldsucceed/1918.v | 376 --- test-suite/bugs/closed/shouldsucceed/1925.v | 22 - test-suite/bugs/closed/shouldsucceed/1931.v | 29 - test-suite/bugs/closed/shouldsucceed/1935.v | 21 - test-suite/bugs/closed/shouldsucceed/1939.v | 19 - test-suite/bugs/closed/shouldsucceed/1944.v | 9 - test-suite/bugs/closed/shouldsucceed/1951.v | 63 - test-suite/bugs/closed/shouldsucceed/1962.v | 55 - test-suite/bugs/closed/shouldsucceed/1963.v | 19 - test-suite/bugs/closed/shouldsucceed/1977.v | 4 - test-suite/bugs/closed/shouldsucceed/1981.v | 5 - test-suite/bugs/closed/shouldsucceed/2001.v | 22 - test-suite/bugs/closed/shouldsucceed/2017.v | 15 - test-suite/bugs/closed/shouldsucceed/2021.v | 23 - test-suite/bugs/closed/shouldsucceed/2027.v | 11 - test-suite/bugs/closed/shouldsucceed/2083.v | 27 - test-suite/bugs/closed/shouldsucceed/2089.v | 17 - test-suite/bugs/closed/shouldsucceed/2095.v | 19 - test-suite/bugs/closed/shouldsucceed/2108.v | 22 - test-suite/bugs/closed/shouldsucceed/2117.v | 56 - test-suite/bugs/closed/shouldsucceed/2123.v | 11 - test-suite/bugs/closed/shouldsucceed/2127.v | 8 - test-suite/bugs/closed/shouldsucceed/2135.v | 9 - test-suite/bugs/closed/shouldsucceed/2136.v | 61 - test-suite/bugs/closed/shouldsucceed/2137.v | 52 - test-suite/bugs/closed/shouldsucceed/2139.v | 24 - test-suite/bugs/closed/shouldsucceed/2141.v | 14 - test-suite/bugs/closed/shouldsucceed/2145.v | 20 - test-suite/bugs/closed/shouldsucceed/2181.v | 3 - test-suite/bugs/closed/shouldsucceed/2193.v | 31 - test-suite/bugs/closed/shouldsucceed/2230.v | 6 - test-suite/bugs/closed/shouldsucceed/2231.v | 3 - test-suite/bugs/closed/shouldsucceed/2244.v | 19 - test-suite/bugs/closed/shouldsucceed/2255.v | 21 - test-suite/bugs/closed/shouldsucceed/2262.v | 11 - test-suite/bugs/closed/shouldsucceed/2281.v | 50 - test-suite/bugs/closed/shouldsucceed/2295.v | 11 - test-suite/bugs/closed/shouldsucceed/2299.v | 13 - test-suite/bugs/closed/shouldsucceed/2300.v | 15 - test-suite/bugs/closed/shouldsucceed/2303.v | 4 - test-suite/bugs/closed/shouldsucceed/2304.v | 4 - test-suite/bugs/closed/shouldsucceed/2307.v | 3 - test-suite/bugs/closed/shouldsucceed/2320.v | 14 - test-suite/bugs/closed/shouldsucceed/2342.v | 8 - test-suite/bugs/closed/shouldsucceed/2347.v | 10 - test-suite/bugs/closed/shouldsucceed/2350.v | 6 - test-suite/bugs/closed/shouldsucceed/2353.v | 12 - test-suite/bugs/closed/shouldsucceed/2360.v | 13 - test-suite/bugs/closed/shouldsucceed/2362.v | 38 - test-suite/bugs/closed/shouldsucceed/2375.v | 18 - test-suite/bugs/closed/shouldsucceed/2378.v | 608 ---- test-suite/bugs/closed/shouldsucceed/2388.v | 10 - test-suite/bugs/closed/shouldsucceed/2393.v | 13 - test-suite/bugs/closed/shouldsucceed/2404.v | 46 - test-suite/bugs/closed/shouldsucceed/2456.v | 53 - test-suite/bugs/closed/shouldsucceed/2464.v | 39 - test-suite/bugs/closed/shouldsucceed/2467.v | 49 - test-suite/bugs/closed/shouldsucceed/2473.v | 39 - test-suite/bugs/closed/shouldsucceed/2603.v | 33 - test-suite/bugs/closed/shouldsucceed/2608.v | 34 - test-suite/bugs/closed/shouldsucceed/2613.v | 17 - test-suite/bugs/closed/shouldsucceed/2615.v | 14 - test-suite/bugs/closed/shouldsucceed/2616.v | 7 - test-suite/bugs/closed/shouldsucceed/2629.v | 22 - test-suite/bugs/closed/shouldsucceed/2640.v | 17 - test-suite/bugs/closed/shouldsucceed/2668.v | 6 - test-suite/bugs/closed/shouldsucceed/2732.v | 19 - test-suite/bugs/closed/shouldsucceed/2733.v | 26 - test-suite/bugs/closed/shouldsucceed/2734.v | 15 - test-suite/bugs/closed/shouldsucceed/2750.v | 23 - test-suite/bugs/closed/shouldsucceed/2817.v | 9 - test-suite/bugs/closed/shouldsucceed/2836.v | 39 - test-suite/bugs/closed/shouldsucceed/2837.v | 15 - test-suite/bugs/closed/shouldsucceed/2928.v | 11 - test-suite/bugs/closed/shouldsucceed/2983.v | 8 - test-suite/bugs/closed/shouldsucceed/2995.v | 9 - test-suite/bugs/closed/shouldsucceed/3000.v | 2 - test-suite/bugs/closed/shouldsucceed/3004.v | 7 - test-suite/bugs/closed/shouldsucceed/3008.v | 29 - test-suite/bugs/closed/shouldsucceed/335.v | 5 - test-suite/bugs/closed/shouldsucceed/348.v | 13 - test-suite/bugs/closed/shouldsucceed/38.v | 22 - test-suite/bugs/closed/shouldsucceed/545.v | 5 - test-suite/bugs/closed/shouldsucceed/808_2411.v | 27 - test-suite/bugs/closed/shouldsucceed/846.v | 213 -- test-suite/bugs/closed/shouldsucceed/931.v | 7 - test-suite/bugs/opened/1338.v-disabled | 12 + test-suite/bugs/opened/1501.v | 96 + test-suite/bugs/opened/1596.v | 261 ++ test-suite/bugs/opened/1671.v | 12 + test-suite/bugs/opened/1773.v | 10 - test-suite/bugs/opened/1811.v | 10 + test-suite/bugs/opened/2572.v-disabled | 187 ++ test-suite/bugs/opened/2652a.v-disabled | 106 + test-suite/bugs/opened/2652b.v-disabled | 88 + test-suite/bugs/opened/2800.v | 6 + test-suite/bugs/opened/2814.v | 5 + test-suite/bugs/opened/2951.v | 1 + test-suite/bugs/opened/3010.v-disabled | 1 + test-suite/bugs/opened/3045.v | 30 + test-suite/bugs/opened/3071.v | 5 + test-suite/bugs/opened/3092.v | 9 + test-suite/bugs/opened/3100.v | 9 + test-suite/bugs/opened/3166.v | 83 + test-suite/bugs/opened/3186.v-disabled | 4 + test-suite/bugs/opened/3209.v | 17 + test-suite/bugs/opened/3230.v | 14 + test-suite/bugs/opened/3248.v | 17 + test-suite/bugs/opened/3263.v | 231 ++ test-suite/bugs/opened/3277.v | 7 + test-suite/bugs/opened/3278.v | 25 + test-suite/bugs/opened/3283.v | 28 + test-suite/bugs/opened/3295.v | 104 + test-suite/bugs/opened/3298.v | 23 + test-suite/bugs/opened/3304.v | 3 + test-suite/bugs/opened/3311.v | 10 + test-suite/bugs/opened/3312.v | 5 + test-suite/bugs/opened/3320.v | 4 + test-suite/bugs/opened/3326.v | 18 + test-suite/bugs/opened/3343.v | 46 + test-suite/bugs/opened/3345.v | 144 + test-suite/bugs/opened/3357.v | 9 + test-suite/bugs/opened/3363.v | 26 + test-suite/bugs/opened/3370.v | 12 + test-suite/bugs/opened/3383.v | 7 + test-suite/bugs/opened/3395.v | 230 ++ test-suite/bugs/opened/3410.v | 1 + test-suite/bugs/opened/3459.v | 31 + test-suite/bugs/opened/3461.v | 5 + test-suite/bugs/opened/3463.v | 13 + test-suite/bugs/opened/3467.v | 6 + test-suite/bugs/opened/3478.v-disabled | 8 + test-suite/bugs/opened/3490.v | 27 + test-suite/bugs/opened/3491.v | 2 + test-suite/bugs/opened/3509.v | 18 + test-suite/bugs/opened/3510.v | 34 + test-suite/bugs/opened/3554.v | 1 + test-suite/bugs/opened/3562.v | 2 + test-suite/bugs/opened/3626.v | 7 + test-suite/bugs/opened/3655.v | 9 + test-suite/bugs/opened/3657.v | 33 + test-suite/bugs/opened/3670.v | 19 + test-suite/bugs/opened/3675.v | 20 + test-suite/bugs/opened/3681.v | 20 + test-suite/bugs/opened/3685.v | 74 + test-suite/bugs/opened/3753.v | 4 + test-suite/bugs/opened/3754.v | 282 ++ test-suite/bugs/opened/3786.v | 40 + test-suite/bugs/opened/3788.v | 5 + test-suite/bugs/opened/3808.v | 2 + test-suite/bugs/opened/3819.v | 11 + test-suite/bugs/opened/3849.v | 8 + test-suite/bugs/opened/743.v | 12 + test-suite/bugs/opened/HoTT_coq_106.v | 52 + test-suite/bugs/opened/HoTT_coq_120.v | 136 + .../bugs/opened/shouldnotfail/1338.v-disabled | 12 - test-suite/bugs/opened/shouldnotfail/1501.v | 93 - test-suite/bugs/opened/shouldnotfail/1596.v | 242 -- test-suite/bugs/opened/shouldnotfail/1671.v | 12 - test-suite/bugs/opened/shouldnotfail/1811.v | 9 - test-suite/bugs/opened/shouldnotfail/2310.v | 17 - test-suite/bugs/opened/shouldnotfail/743.v | 12 - test-suite/check | 4 - test-suite/complexity/injection.v | 8 +- test-suite/coqchk/univ.v | 35 + test-suite/failure/Case1.v | 2 +- test-suite/failure/Case10.v | 2 +- test-suite/failure/Case11.v | 2 +- test-suite/failure/Case12.v | 2 +- test-suite/failure/Case13.v | 2 +- test-suite/failure/Case14.v | 2 +- test-suite/failure/Case15.v | 2 +- test-suite/failure/Case16.v | 2 +- test-suite/failure/Case2.v | 2 +- test-suite/failure/Case3.v | 2 +- test-suite/failure/Case4.v | 2 +- test-suite/failure/Case5.v | 2 +- test-suite/failure/Case6.v | 2 +- test-suite/failure/Case7.v | 2 +- test-suite/failure/Case8.v | 2 +- test-suite/failure/Case9.v | 8 +- test-suite/failure/ClearBody.v | 2 +- test-suite/failure/ImportedCoercion.v | 2 +- test-suite/failure/Notations.v | 2 +- test-suite/failure/Reordering.v | 2 +- test-suite/failure/Sections.v | 4 +- test-suite/failure/Tauto.v | 4 +- test-suite/failure/Uminus.v | 69 +- test-suite/failure/autorewritein.v | 2 +- test-suite/failure/cases.v | 2 +- test-suite/failure/check.v | 2 +- test-suite/failure/circular_subtyping.v | 10 + test-suite/failure/circular_subtyping1.v | 7 - test-suite/failure/circular_subtyping2.v | 8 - test-suite/failure/clash_cons.v | 4 +- test-suite/failure/clashes.v | 2 +- test-suite/failure/cofixpoint.v | 15 + test-suite/failure/coqbugs0266.v | 2 +- test-suite/failure/evar1.v | 2 +- test-suite/failure/evarclear1.v | 2 +- test-suite/failure/evarclear2.v | 2 +- test-suite/failure/evarlemma.v | 2 +- test-suite/failure/fixpoint1.v | 6 +- test-suite/failure/fixpoint2.v | 2 +- test-suite/failure/fixpoint3.v | 2 +- test-suite/failure/fixpoint4.v | 2 +- test-suite/failure/guard-cofix.v | 43 + test-suite/failure/guard.v | 8 +- test-suite/failure/illtype1.v | 4 +- test-suite/failure/inductive.v | 27 + test-suite/failure/inductive1.v | 4 - test-suite/failure/inductive2.v | 4 - test-suite/failure/inductive3.v | 5 - test-suite/failure/inductive4.v | 15 - test-suite/failure/ltac1.v | 2 +- test-suite/failure/ltac2.v | 2 +- test-suite/failure/ltac4.v | 3 +- test-suite/failure/pattern.v | 2 +- test-suite/failure/positivity.v | 4 +- test-suite/failure/proofirrelevance.v | 7 +- test-suite/failure/prop-set-proof-irrelevance.v | 6 +- test-suite/failure/redef.v | 4 +- test-suite/failure/rewrite_in_goal.v | 2 +- test-suite/failure/rewrite_in_hyp.v | 2 +- test-suite/failure/rewrite_in_hyp2.v | 2 +- test-suite/failure/search.v | 4 +- test-suite/failure/sortelim.v | 149 + test-suite/failure/subterm.v | 45 + test-suite/failure/subterm2.v | 48 + test-suite/failure/subterm3.v | 29 + test-suite/failure/subtyping.v | 2 +- test-suite/failure/subtyping2.v | 2 +- test-suite/failure/univ_include.v | 4 +- test-suite/failure/universes-buraliforti-redef.v | 6 +- test-suite/failure/universes-buraliforti.v | 2 +- test-suite/failure/universes-sections1.v | 2 +- test-suite/failure/universes-sections2.v | 2 +- test-suite/failure/universes.v | 2 +- test-suite/failure/universes3.v | 2 +- test-suite/ide/blocking-futures.fake | 16 + test-suite/ide/undo001.fake | 10 +- test-suite/ide/undo002.fake | 10 +- test-suite/ide/undo003.fake | 6 +- test-suite/ide/undo004.fake | 14 +- test-suite/ide/undo005.fake | 16 +- test-suite/ide/undo006.fake | 12 +- test-suite/ide/undo007.fake | 17 - test-suite/ide/undo008.fake | 20 +- test-suite/ide/undo009.fake | 25 +- test-suite/ide/undo010.fake | 40 +- test-suite/ide/undo011.fake | 46 +- test-suite/ide/undo012.fake | 42 +- test-suite/ide/undo013.fake | 44 +- test-suite/ide/undo014.fake | 36 +- test-suite/ide/undo015.fake | 42 +- test-suite/ide/undo016.fake | 49 +- test-suite/ide/undo017.fake | 12 +- test-suite/ide/undo018.fake | 12 +- test-suite/ide/undo019.fake | 14 +- test-suite/ide/undo020.fake | 27 + test-suite/ide/undo021.fake | 29 + test-suite/ide/undo022.fake | 41 + test-suite/ideal-features/Apply.v | 2 +- test-suite/interactive/ParalITP.v | 47 + test-suite/interactive/ParalITP_smallproofs.v | 3041 ++++++++++++++++++++ test-suite/micromega/example.v | 5 +- test-suite/micromega/heap3_vcgen_25.v | 2 +- test-suite/micromega/qexample.v | 1 - test-suite/micromega/rexample.v | 1 - test-suite/micromega/zomicron.v | 2 +- test-suite/misc/berardi_test.v | 2 +- test-suite/modules/Przyklad.v | 4 +- test-suite/output/Arguments.out | 88 +- test-suite/output/Arguments.v | 24 +- test-suite/output/ArgumentsScope.out | 19 +- test-suite/output/Arguments_renaming.out | 21 +- test-suite/output/Cases.out | 38 +- test-suite/output/Cases.v | 31 + test-suite/output/Errors.out | 5 + test-suite/output/Errors.v | 9 + test-suite/output/Existentials.out | 8 +- test-suite/output/Extraction_matchs_2413.v | 10 +- test-suite/output/Implicit.out | 1 + test-suite/output/InitSyntax.out | 2 +- test-suite/output/Intuition.out | 3 +- test-suite/output/Match_subterm.out | 2 + test-suite/output/Nametab.out | 24 +- test-suite/output/Naming.out | 48 +- test-suite/output/Notations.out | 45 +- test-suite/output/Notations.v | 12 +- test-suite/output/Notations2.out | 8 +- test-suite/output/PrintAssumptions.out | 5 + test-suite/output/PrintInfos.out | 45 +- test-suite/output/PrintInfos.v | 22 +- test-suite/output/Search.out | 116 +- test-suite/output/Search.v | 24 + test-suite/output/SearchHead.out | 39 + test-suite/output/SearchHead.v | 19 + test-suite/output/SearchPattern.out | 91 +- test-suite/output/SearchPattern.v | 17 + test-suite/output/SearchRewrite.out | 3 + test-suite/output/SearchRewrite.v | 9 + test-suite/output/TranspModtype.out | 8 + test-suite/output/inference.out | 14 +- test-suite/output/inference.v | 4 + test-suite/output/names.out | 6 + test-suite/output/names.v | 5 + test-suite/output/reduction.v | 2 +- test-suite/output/set.out | 7 +- test-suite/output/simpl.v | 6 +- test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v | 3041 ++++++++++++++++++++ test-suite/success/AdvancedCanonicalStructure.v | 28 +- test-suite/success/Case11.v | 6 +- test-suite/success/Case12.v | 4 +- test-suite/success/Case16.v | 4 +- test-suite/success/Case17.v | 12 +- test-suite/success/Case20.v | 35 + test-suite/success/Case21.v | 15 + test-suite/success/Case22.v | 7 + test-suite/success/Case7.v | 4 +- test-suite/success/Case9.v | 16 +- test-suite/success/CaseInClause.v | 22 + test-suite/success/Cases-bug1834.v | 2 +- test-suite/success/Cases-bug3758.v | 17 + test-suite/success/Cases.v | 278 +- test-suite/success/CasesDep.v | 26 +- test-suite/success/Check.v | 4 +- test-suite/success/Field.v | 2 +- test-suite/success/Fixpoint.v | 4 +- test-suite/success/Funind.v | 7 +- test-suite/success/ImplicitArguments.v | 8 +- test-suite/success/Inductive.v | 22 +- test-suite/success/Injection.v | 52 +- test-suite/success/Inversion.v | 53 + test-suite/success/LegacyField.v | 76 - test-suite/success/LetPat.v | 10 +- test-suite/success/MatchFail.v | 2 +- test-suite/success/NumberScopes.v | 62 + test-suite/success/ProgramWf.v | 4 +- test-suite/success/Projection.v | 6 + test-suite/success/RecTutorial.v | 15 +- test-suite/success/Scopes.v | 14 + test-suite/success/Tauto.v | 2 +- test-suite/success/TestRefine.v | 10 +- test-suite/success/apply.v | 120 +- test-suite/success/applyTC.v | 15 + test-suite/success/auto.v | 23 +- test-suite/success/cc.v | 27 + test-suite/success/change.v | 21 + test-suite/success/coercions.v | 10 +- test-suite/success/decl_mode.v | 2 +- test-suite/success/destruct.v | 337 ++- test-suite/success/eauto.v | 2 +- test-suite/success/eqdecide.v | 2 +- test-suite/success/evars.v | 48 +- test-suite/success/extraction.v | 2 +- test-suite/success/extraction_dep.v | 46 + test-suite/success/fix.v | 6 +- test-suite/success/implicit.v | 2 +- test-suite/success/indelim.v | 61 + test-suite/success/inds_type_sec.v | 2 +- test-suite/success/induct.v | 91 +- test-suite/success/instantiate.v | 11 - test-suite/success/intros.v | 28 + test-suite/success/keyedrewrite.v | 24 + test-suite/success/letproj.v | 9 + test-suite/success/ltac.v | 12 +- test-suite/success/ltac_plus.v | 12 + test-suite/success/mutual_ind.v | 2 +- test-suite/success/namedunivs.v | 102 + test-suite/success/paralleltac.v | 46 + test-suite/success/params_ind.v | 4 - test-suite/success/polymorphism.v | 288 +- test-suite/success/primitiveproj.v | 190 ++ test-suite/success/proof_using.v | 53 + test-suite/success/refine.v | 10 +- test-suite/success/rewrite.v | 19 + test-suite/success/rewrite_dep.v | 33 + test-suite/success/rewrite_strat.v | 53 + test-suite/success/setoid_test.v | 2 +- test-suite/success/setoid_unif.v | 27 + test-suite/success/simpl.v | 52 + test-suite/success/somatching.v | 64 + test-suite/success/unfold.v | 2 +- test-suite/success/unicode_utf8.v | 3 +- test-suite/success/unification.v | 6 +- test-suite/success/univscompute.v | 32 + test-suite/typeclasses/NewSetoid.v | 4 +- test-suite/typeclasses/backtrack.v | 84 + test-suite/typeclasses/deftwice.v | 9 + test-suite/vio/seff.v | 10 + test-suite/vio/simple.v | 2 + test-suite/vio/univ_constraints_statements.v | 2 + 892 files changed, 31398 insertions(+), 5976 deletions(-) create mode 100644 test-suite/bugs/2428.v create mode 100644 test-suite/bugs/closed/1100.v create mode 100644 test-suite/bugs/closed/121.v create mode 100644 test-suite/bugs/closed/1243.v create mode 100644 test-suite/bugs/closed/1302.v create mode 100644 test-suite/bugs/closed/1322.v create mode 100644 test-suite/bugs/closed/1411.v create mode 100644 test-suite/bugs/closed/1414.v create mode 100644 test-suite/bugs/closed/1416.v create mode 100644 test-suite/bugs/closed/1419.v create mode 100644 test-suite/bugs/closed/1425.v create mode 100644 test-suite/bugs/closed/1446.v create mode 100644 test-suite/bugs/closed/1448.v create mode 100644 test-suite/bugs/closed/1477.v create mode 100644 test-suite/bugs/closed/1483.v create mode 100644 test-suite/bugs/closed/1507.v create mode 100644 test-suite/bugs/closed/1568.v create mode 100644 test-suite/bugs/closed/1576.v create mode 100644 test-suite/bugs/closed/1582.v create mode 100644 test-suite/bugs/closed/1604.v create mode 100644 test-suite/bugs/closed/1614.v create mode 100644 test-suite/bugs/closed/1618.v create mode 100644 test-suite/bugs/closed/1634.v create mode 100644 test-suite/bugs/closed/1643.v create mode 100644 test-suite/bugs/closed/1680.v create mode 100644 test-suite/bugs/closed/1683.v create mode 100644 test-suite/bugs/closed/1696.v create mode 100644 test-suite/bugs/closed/1703.v create mode 100644 test-suite/bugs/closed/1704.v create mode 100644 test-suite/bugs/closed/1711.v create mode 100644 test-suite/bugs/closed/1718.v create mode 100644 test-suite/bugs/closed/1738.v create mode 100644 test-suite/bugs/closed/1740.v create mode 100644 test-suite/bugs/closed/1754.v create mode 100644 test-suite/bugs/closed/1773.v create mode 100644 test-suite/bugs/closed/1774.v create mode 100644 test-suite/bugs/closed/1775.v create mode 100644 test-suite/bugs/closed/1776.v create mode 100644 test-suite/bugs/closed/1779.v create mode 100644 test-suite/bugs/closed/1784.v create mode 100644 test-suite/bugs/closed/1791.v create mode 100644 test-suite/bugs/closed/1834.v create mode 100644 test-suite/bugs/closed/1844.v create mode 100644 test-suite/bugs/closed/1865.v create mode 100644 test-suite/bugs/closed/1891.v create mode 100644 test-suite/bugs/closed/1898.v create mode 100644 test-suite/bugs/closed/1900.v create mode 100644 test-suite/bugs/closed/1901.v create mode 100644 test-suite/bugs/closed/1905.v create mode 100644 test-suite/bugs/closed/1907.v create mode 100644 test-suite/bugs/closed/1912.v create mode 100644 test-suite/bugs/closed/1915.v create mode 100644 test-suite/bugs/closed/1918.v create mode 100644 test-suite/bugs/closed/1925.v create mode 100644 test-suite/bugs/closed/1931.v create mode 100644 test-suite/bugs/closed/1935.v create mode 100644 test-suite/bugs/closed/1939.v create mode 100644 test-suite/bugs/closed/1944.v create mode 100644 test-suite/bugs/closed/1951.v create mode 100644 test-suite/bugs/closed/1962.v create mode 100644 test-suite/bugs/closed/1963.v create mode 100644 test-suite/bugs/closed/1977.v create mode 100644 test-suite/bugs/closed/1981.v create mode 100644 test-suite/bugs/closed/2001.v create mode 100644 test-suite/bugs/closed/2006.v create mode 100644 test-suite/bugs/closed/2017.v create mode 100644 test-suite/bugs/closed/2021.v create mode 100644 test-suite/bugs/closed/2027.v create mode 100644 test-suite/bugs/closed/2083.v create mode 100644 test-suite/bugs/closed/2089.v create mode 100644 test-suite/bugs/closed/2095.v create mode 100644 test-suite/bugs/closed/2108.v create mode 100644 test-suite/bugs/closed/2117.v create mode 100644 test-suite/bugs/closed/2123.v create mode 100644 test-suite/bugs/closed/2127.v create mode 100644 test-suite/bugs/closed/2135.v create mode 100644 test-suite/bugs/closed/2136.v create mode 100644 test-suite/bugs/closed/2137.v create mode 100644 test-suite/bugs/closed/2139.v create mode 100644 test-suite/bugs/closed/2141.v create mode 100644 test-suite/bugs/closed/2145.v create mode 100644 test-suite/bugs/closed/2149.v create mode 100644 test-suite/bugs/closed/2164.v create mode 100644 test-suite/bugs/closed/2181.v create mode 100644 test-suite/bugs/closed/2193.v create mode 100644 test-suite/bugs/closed/2230.v create mode 100644 test-suite/bugs/closed/2231.v create mode 100644 test-suite/bugs/closed/2244.v create mode 100644 test-suite/bugs/closed/2250.v create mode 100644 test-suite/bugs/closed/2251.v create mode 100644 test-suite/bugs/closed/2255.v create mode 100644 test-suite/bugs/closed/2262.v create mode 100644 test-suite/bugs/closed/2281.v create mode 100644 test-suite/bugs/closed/2295.v create mode 100644 test-suite/bugs/closed/2299.v create mode 100644 test-suite/bugs/closed/2300.v create mode 100644 test-suite/bugs/closed/2303.v create mode 100644 test-suite/bugs/closed/2304.v create mode 100644 test-suite/bugs/closed/2307.v create mode 100644 test-suite/bugs/closed/2310.v create mode 100644 test-suite/bugs/closed/2320.v create mode 100644 test-suite/bugs/closed/2342.v create mode 100644 test-suite/bugs/closed/2347.v create mode 100644 test-suite/bugs/closed/2350.v create mode 100644 test-suite/bugs/closed/2353.v create mode 100644 test-suite/bugs/closed/2360.v create mode 100644 test-suite/bugs/closed/2362.v create mode 100644 test-suite/bugs/closed/2375.v create mode 100644 test-suite/bugs/closed/2378.v create mode 100644 test-suite/bugs/closed/2388.v create mode 100644 test-suite/bugs/closed/2393.v create mode 100644 test-suite/bugs/closed/2404.v create mode 100644 test-suite/bugs/closed/2406.v create mode 100644 test-suite/bugs/closed/2447.v create mode 100644 test-suite/bugs/closed/2456.v create mode 100644 test-suite/bugs/closed/2464.v create mode 100644 test-suite/bugs/closed/2467.v create mode 100644 test-suite/bugs/closed/2473.v create mode 100644 test-suite/bugs/closed/2586.v create mode 100644 test-suite/bugs/closed/2603.v create mode 100644 test-suite/bugs/closed/2608.v create mode 100644 test-suite/bugs/closed/2613.v create mode 100644 test-suite/bugs/closed/2615.v create mode 100644 test-suite/bugs/closed/2616.v create mode 100644 test-suite/bugs/closed/2629.v create mode 100644 test-suite/bugs/closed/2640.v create mode 100644 test-suite/bugs/closed/2667.v create mode 100644 test-suite/bugs/closed/2668.v create mode 100644 test-suite/bugs/closed/2670.v create mode 100644 test-suite/bugs/closed/2680.v create mode 100644 test-suite/bugs/closed/2713.v create mode 100644 test-suite/bugs/closed/2729.v create mode 100644 test-suite/bugs/closed/2732.v create mode 100644 test-suite/bugs/closed/2733.v create mode 100644 test-suite/bugs/closed/2734.v create mode 100644 test-suite/bugs/closed/2750.v create mode 100644 test-suite/bugs/closed/2810.v create mode 100644 test-suite/bugs/closed/2817.v create mode 100644 test-suite/bugs/closed/2818.v create mode 100644 test-suite/bugs/closed/2828.v create mode 100644 test-suite/bugs/closed/2830.v create mode 100644 test-suite/bugs/closed/2834.v create mode 100644 test-suite/bugs/closed/2836.v create mode 100644 test-suite/bugs/closed/2837.v create mode 100644 test-suite/bugs/closed/2839.v create mode 100644 test-suite/bugs/closed/2846.v create mode 100644 test-suite/bugs/closed/2848.v create mode 100644 test-suite/bugs/closed/2850.v create mode 100644 test-suite/bugs/closed/2854.v create mode 100644 test-suite/bugs/closed/2876.v create mode 100644 test-suite/bugs/closed/2883.v create mode 100644 test-suite/bugs/closed/2900.v create mode 100644 test-suite/bugs/closed/2920.v create mode 100644 test-suite/bugs/closed/2923.v create mode 100644 test-suite/bugs/closed/2928.v create mode 100644 test-suite/bugs/closed/2930.v create mode 100644 test-suite/bugs/closed/2945.v create mode 100644 test-suite/bugs/closed/2966.v create mode 100644 test-suite/bugs/closed/2969.v create mode 100644 test-suite/bugs/closed/2981.v create mode 100644 test-suite/bugs/closed/2983.v create mode 100644 test-suite/bugs/closed/2990.v create mode 100644 test-suite/bugs/closed/2994.v create mode 100644 test-suite/bugs/closed/2995.v create mode 100644 test-suite/bugs/closed/2996.v create mode 100644 test-suite/bugs/closed/3000.v create mode 100644 test-suite/bugs/closed/3001.v create mode 100644 test-suite/bugs/closed/3004.v create mode 100644 test-suite/bugs/closed/3008.v create mode 100644 test-suite/bugs/closed/3010b.v create mode 100644 test-suite/bugs/closed/3016.v create mode 100644 test-suite/bugs/closed/3017.v create mode 100644 test-suite/bugs/closed/3022.v create mode 100644 test-suite/bugs/closed/3036.v create mode 100644 test-suite/bugs/closed/3037.v create mode 100644 test-suite/bugs/closed/3043.v create mode 100644 test-suite/bugs/closed/3045.v create mode 100644 test-suite/bugs/closed/3050.v create mode 100644 test-suite/bugs/closed/3054.v create mode 100644 test-suite/bugs/closed/3062.v create mode 100644 test-suite/bugs/closed/3068.v create mode 100644 test-suite/bugs/closed/3088.v create mode 100644 test-suite/bugs/closed/3093.v create mode 100644 test-suite/bugs/closed/3142.v create mode 100644 test-suite/bugs/closed/3164.v create mode 100644 test-suite/bugs/closed/3188.v create mode 100644 test-suite/bugs/closed/3205.v create mode 100644 test-suite/bugs/closed/3212.v create mode 100644 test-suite/bugs/closed/3217.v create mode 100644 test-suite/bugs/closed/3228.v create mode 100644 test-suite/bugs/closed/3242.v create mode 100644 test-suite/bugs/closed/3251.v create mode 100644 test-suite/bugs/closed/3258.v create mode 100644 test-suite/bugs/closed/3259.v create mode 100644 test-suite/bugs/closed/3260.v create mode 100644 test-suite/bugs/closed/3262.v create mode 100644 test-suite/bugs/closed/3264.v create mode 100644 test-suite/bugs/closed/3265.v create mode 100644 test-suite/bugs/closed/3266.v create mode 100644 test-suite/bugs/closed/3267.v create mode 100644 test-suite/bugs/closed/328.v create mode 100644 test-suite/bugs/closed/3281.v create mode 100644 test-suite/bugs/closed/3282.v create mode 100644 test-suite/bugs/closed/3284.v create mode 100644 test-suite/bugs/closed/3285.v create mode 100644 test-suite/bugs/closed/3286.v create mode 100644 test-suite/bugs/closed/3287.v create mode 100644 test-suite/bugs/closed/3289.v create mode 100644 test-suite/bugs/closed/329.v create mode 100644 test-suite/bugs/closed/3291.v create mode 100644 test-suite/bugs/closed/3294.v create mode 100644 test-suite/bugs/closed/3297.v create mode 100644 test-suite/bugs/closed/3300.v create mode 100644 test-suite/bugs/closed/3305.v create mode 100644 test-suite/bugs/closed/3306.v create mode 100644 test-suite/bugs/closed/3309.v create mode 100644 test-suite/bugs/closed/331.v create mode 100644 test-suite/bugs/closed/3310.v create mode 100644 test-suite/bugs/closed/3314.v create mode 100644 test-suite/bugs/closed/3315.v create mode 100644 test-suite/bugs/closed/3317.v create mode 100644 test-suite/bugs/closed/3319.v create mode 100644 test-suite/bugs/closed/3321.v create mode 100644 test-suite/bugs/closed/3322.v create mode 100644 test-suite/bugs/closed/3323.v create mode 100644 test-suite/bugs/closed/3324.v create mode 100644 test-suite/bugs/closed/3325.v create mode 100644 test-suite/bugs/closed/3326.v create mode 100644 test-suite/bugs/closed/3329.v create mode 100644 test-suite/bugs/closed/3330.v create mode 100644 test-suite/bugs/closed/3331.v create mode 100644 test-suite/bugs/closed/3332.v create mode 100644 test-suite/bugs/closed/3336.v create mode 100644 test-suite/bugs/closed/3337.v create mode 100644 test-suite/bugs/closed/3338.v create mode 100644 test-suite/bugs/closed/3344.v create mode 100644 test-suite/bugs/closed/3346.v create mode 100644 test-suite/bugs/closed/3347.v create mode 100644 test-suite/bugs/closed/3348.v create mode 100644 test-suite/bugs/closed/335.v create mode 100644 test-suite/bugs/closed/3350.v create mode 100644 test-suite/bugs/closed/3352.v create mode 100644 test-suite/bugs/closed/3354.v create mode 100644 test-suite/bugs/closed/3355.v create mode 100644 test-suite/bugs/closed/3368.v create mode 100644 test-suite/bugs/closed/3372.v create mode 100644 test-suite/bugs/closed/3373.v create mode 100644 test-suite/bugs/closed/3374.v create mode 100644 test-suite/bugs/closed/3375.v create mode 100644 test-suite/bugs/closed/3377.v create mode 100644 test-suite/bugs/closed/3382.v create mode 100644 test-suite/bugs/closed/3386.v create mode 100644 test-suite/bugs/closed/3387.v create mode 100644 test-suite/bugs/closed/3388.v create mode 100644 test-suite/bugs/closed/3390.v create mode 100644 test-suite/bugs/closed/3392.v create mode 100644 test-suite/bugs/closed/3393.v create mode 100644 test-suite/bugs/closed/3402.v create mode 100644 test-suite/bugs/closed/3408.v create mode 100644 test-suite/bugs/closed/3416.v create mode 100644 test-suite/bugs/closed/3417.v create mode 100644 test-suite/bugs/closed/3422.v create mode 100644 test-suite/bugs/closed/3424.v create mode 100644 test-suite/bugs/closed/3427.v create mode 100644 test-suite/bugs/closed/3428.v create mode 100644 test-suite/bugs/closed/3439.v create mode 100644 test-suite/bugs/closed/3453.v create mode 100644 test-suite/bugs/closed/3454.v create mode 100644 test-suite/bugs/closed/3469.v create mode 100644 test-suite/bugs/closed/3477.v create mode 100644 test-suite/bugs/closed/348.v create mode 100644 test-suite/bugs/closed/3480.v create mode 100644 test-suite/bugs/closed/3481.v create mode 100644 test-suite/bugs/closed/3482.v create mode 100644 test-suite/bugs/closed/3483.v create mode 100644 test-suite/bugs/closed/3484.v create mode 100644 test-suite/bugs/closed/3485.v create mode 100644 test-suite/bugs/closed/3487.v create mode 100644 test-suite/bugs/closed/3505.v create mode 100644 test-suite/bugs/closed/3520.v create mode 100644 test-suite/bugs/closed/3531.v create mode 100644 test-suite/bugs/closed/3537.v create mode 100644 test-suite/bugs/closed/3539.v create mode 100644 test-suite/bugs/closed/3542.v create mode 100644 test-suite/bugs/closed/3546.v create mode 100644 test-suite/bugs/closed/3559.v create mode 100644 test-suite/bugs/closed/3561.v create mode 100644 test-suite/bugs/closed/3562.v create mode 100644 test-suite/bugs/closed/3563.v create mode 100644 test-suite/bugs/closed/3566.v create mode 100644 test-suite/bugs/closed/3567.v create mode 100644 test-suite/bugs/closed/3584.v create mode 100644 test-suite/bugs/closed/3593.v create mode 100644 test-suite/bugs/closed/3594.v create mode 100644 test-suite/bugs/closed/3596.v create mode 100644 test-suite/bugs/closed/3616.v create mode 100644 test-suite/bugs/closed/3618.v create mode 100644 test-suite/bugs/closed/3623.v create mode 100644 test-suite/bugs/closed/3624.v create mode 100644 test-suite/bugs/closed/3625.v create mode 100644 test-suite/bugs/closed/3628.v create mode 100644 test-suite/bugs/closed/3633.v create mode 100644 test-suite/bugs/closed/3637.v create mode 100644 test-suite/bugs/closed/3638.v create mode 100644 test-suite/bugs/closed/3640.v create mode 100644 test-suite/bugs/closed/3641.v create mode 100644 test-suite/bugs/closed/3647.v create mode 100644 test-suite/bugs/closed/3648.v create mode 100644 test-suite/bugs/closed/3652.v create mode 100644 test-suite/bugs/closed/3653.v create mode 100644 test-suite/bugs/closed/3654.v create mode 100644 test-suite/bugs/closed/3656.v create mode 100644 test-suite/bugs/closed/3657.v create mode 100644 test-suite/bugs/closed/3658.v create mode 100644 test-suite/bugs/closed/3660.v create mode 100644 test-suite/bugs/closed/3661.v create mode 100644 test-suite/bugs/closed/3662.v create mode 100644 test-suite/bugs/closed/3664.v create mode 100644 test-suite/bugs/closed/3665.v create mode 100644 test-suite/bugs/closed/3666.v create mode 100644 test-suite/bugs/closed/3667.v create mode 100644 test-suite/bugs/closed/3668.v create mode 100644 test-suite/bugs/closed/3670.v create mode 100644 test-suite/bugs/closed/3672.v create mode 100644 test-suite/bugs/closed/3675.v create mode 100644 test-suite/bugs/closed/3682.v create mode 100644 test-suite/bugs/closed/3684.v create mode 100644 test-suite/bugs/closed/3686.v create mode 100644 test-suite/bugs/closed/3692.v create mode 100644 test-suite/bugs/closed/3698.v create mode 100644 test-suite/bugs/closed/3699.v create mode 100644 test-suite/bugs/closed/3700.v create mode 100644 test-suite/bugs/closed/3709.v create mode 100644 test-suite/bugs/closed/3710.v create mode 100644 test-suite/bugs/closed/3723.v create mode 100644 test-suite/bugs/closed/3782.v create mode 100644 test-suite/bugs/closed/3788.v create mode 100644 test-suite/bugs/closed/3792.v create mode 100644 test-suite/bugs/closed/38.v create mode 100644 test-suite/bugs/closed/3804.v create mode 100644 test-suite/bugs/closed/3821.v create mode 100644 test-suite/bugs/closed/3828.v create mode 100644 test-suite/bugs/closed/3848.v create mode 100644 test-suite/bugs/closed/3854.v create mode 100644 test-suite/bugs/closed/3892.v create mode 100644 test-suite/bugs/closed/3895.v create mode 100644 test-suite/bugs/closed/3896.v create mode 100644 test-suite/bugs/closed/3899.v create mode 100644 test-suite/bugs/closed/545.v create mode 100644 test-suite/bugs/closed/808_2411.v create mode 100644 test-suite/bugs/closed/846.v create mode 100644 test-suite/bugs/closed/931.v create mode 100644 test-suite/bugs/closed/HoTT_coq_001.v create mode 100644 test-suite/bugs/closed/HoTT_coq_002.v create mode 100644 test-suite/bugs/closed/HoTT_coq_006.v create mode 100644 test-suite/bugs/closed/HoTT_coq_007.v create mode 100644 test-suite/bugs/closed/HoTT_coq_010.v create mode 100644 test-suite/bugs/closed/HoTT_coq_012.v create mode 100644 test-suite/bugs/closed/HoTT_coq_013.v create mode 100644 test-suite/bugs/closed/HoTT_coq_014.v create mode 100644 test-suite/bugs/closed/HoTT_coq_016.v create mode 100644 test-suite/bugs/closed/HoTT_coq_020.v create mode 100644 test-suite/bugs/closed/HoTT_coq_023.v create mode 100644 test-suite/bugs/closed/HoTT_coq_025.v create mode 100644 test-suite/bugs/closed/HoTT_coq_027.v create mode 100644 test-suite/bugs/closed/HoTT_coq_028.v create mode 100644 test-suite/bugs/closed/HoTT_coq_029.v create mode 100644 test-suite/bugs/closed/HoTT_coq_030.v create mode 100644 test-suite/bugs/closed/HoTT_coq_032.v create mode 100644 test-suite/bugs/closed/HoTT_coq_034.v create mode 100644 test-suite/bugs/closed/HoTT_coq_035.v create mode 100644 test-suite/bugs/closed/HoTT_coq_036.v create mode 100644 test-suite/bugs/closed/HoTT_coq_037.v create mode 100644 test-suite/bugs/closed/HoTT_coq_041.v create mode 100644 test-suite/bugs/closed/HoTT_coq_042.v create mode 100644 test-suite/bugs/closed/HoTT_coq_043.v create mode 100644 test-suite/bugs/closed/HoTT_coq_044.v create mode 100644 test-suite/bugs/closed/HoTT_coq_045.v create mode 100644 test-suite/bugs/closed/HoTT_coq_047.v create mode 100644 test-suite/bugs/closed/HoTT_coq_048.v create mode 100644 test-suite/bugs/closed/HoTT_coq_049.v create mode 100644 test-suite/bugs/closed/HoTT_coq_050.v create mode 100644 test-suite/bugs/closed/HoTT_coq_052.v create mode 100644 test-suite/bugs/closed/HoTT_coq_053.v create mode 100644 test-suite/bugs/closed/HoTT_coq_054.v create mode 100644 test-suite/bugs/closed/HoTT_coq_055.v create mode 100644 test-suite/bugs/closed/HoTT_coq_056.v create mode 100644 test-suite/bugs/closed/HoTT_coq_057.v create mode 100644 test-suite/bugs/closed/HoTT_coq_058.v create mode 100644 test-suite/bugs/closed/HoTT_coq_059.v create mode 100644 test-suite/bugs/closed/HoTT_coq_061.v create mode 100644 test-suite/bugs/closed/HoTT_coq_062.v create mode 100644 test-suite/bugs/closed/HoTT_coq_063.v create mode 100644 test-suite/bugs/closed/HoTT_coq_064.v create mode 100644 test-suite/bugs/closed/HoTT_coq_067.v create mode 100644 test-suite/bugs/closed/HoTT_coq_068.v create mode 100644 test-suite/bugs/closed/HoTT_coq_071.v create mode 100644 test-suite/bugs/closed/HoTT_coq_074.v create mode 100644 test-suite/bugs/closed/HoTT_coq_077.v create mode 100644 test-suite/bugs/closed/HoTT_coq_078.v create mode 100644 test-suite/bugs/closed/HoTT_coq_079.v create mode 100644 test-suite/bugs/closed/HoTT_coq_080.v create mode 100644 test-suite/bugs/closed/HoTT_coq_081.v create mode 100644 test-suite/bugs/closed/HoTT_coq_082.v create mode 100644 test-suite/bugs/closed/HoTT_coq_083.v create mode 100644 test-suite/bugs/closed/HoTT_coq_084.v create mode 100644 test-suite/bugs/closed/HoTT_coq_085.v create mode 100644 test-suite/bugs/closed/HoTT_coq_087.v create mode 100644 test-suite/bugs/closed/HoTT_coq_088.v create mode 100644 test-suite/bugs/closed/HoTT_coq_089.v create mode 100644 test-suite/bugs/closed/HoTT_coq_090.v create mode 100644 test-suite/bugs/closed/HoTT_coq_091.v create mode 100644 test-suite/bugs/closed/HoTT_coq_093.v create mode 100644 test-suite/bugs/closed/HoTT_coq_094.v create mode 100644 test-suite/bugs/closed/HoTT_coq_097.v create mode 100644 test-suite/bugs/closed/HoTT_coq_098.v create mode 100644 test-suite/bugs/closed/HoTT_coq_099.v create mode 100644 test-suite/bugs/closed/HoTT_coq_100.v create mode 100644 test-suite/bugs/closed/HoTT_coq_101.v create mode 100644 test-suite/bugs/closed/HoTT_coq_102.v create mode 100644 test-suite/bugs/closed/HoTT_coq_103.v create mode 100644 test-suite/bugs/closed/HoTT_coq_104.v create mode 100644 test-suite/bugs/closed/HoTT_coq_105.v create mode 100644 test-suite/bugs/closed/HoTT_coq_107.v create mode 100644 test-suite/bugs/closed/HoTT_coq_108.v create mode 100644 test-suite/bugs/closed/HoTT_coq_110.v create mode 100644 test-suite/bugs/closed/HoTT_coq_111.v create mode 100644 test-suite/bugs/closed/HoTT_coq_112.v create mode 100644 test-suite/bugs/closed/HoTT_coq_113.v create mode 100644 test-suite/bugs/closed/HoTT_coq_114.v create mode 100644 test-suite/bugs/closed/HoTT_coq_115.v create mode 100644 test-suite/bugs/closed/HoTT_coq_116.v create mode 100644 test-suite/bugs/closed/HoTT_coq_117.v create mode 100644 test-suite/bugs/closed/HoTT_coq_118.v create mode 100644 test-suite/bugs/closed/HoTT_coq_121.v create mode 100644 test-suite/bugs/closed/HoTT_coq_122.v create mode 100644 test-suite/bugs/closed/HoTT_coq_123.v create mode 100644 test-suite/bugs/closed/HoTT_coq_124.v delete mode 100644 test-suite/bugs/closed/shouldfail/1703.v delete mode 100644 test-suite/bugs/closed/shouldfail/1898.v delete mode 100644 test-suite/bugs/closed/shouldfail/1915.v delete mode 100644 test-suite/bugs/closed/shouldfail/2006.v delete mode 100644 test-suite/bugs/closed/shouldfail/2251.v delete mode 100644 test-suite/bugs/closed/shouldfail/2406.v delete mode 100644 test-suite/bugs/closed/shouldfail/2586.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1041.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1100.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/121.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1243.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1302.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1322.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1411.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1414.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1416.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1419.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1425.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1446.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1448.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1477.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1483.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1507.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1519.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1568.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1576.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1582.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1604.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1614.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1618.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1634.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1643.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1680.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1683.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1696.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1704.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1711.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1718.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1738.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1740.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1754.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1773.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1774.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1775.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1776.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1779.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1784.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1791.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1834.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1844.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1865.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1891.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1900.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1901.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1905.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1907.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1912.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1918.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1925.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1931.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1935.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1939.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1944.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1951.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1962.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1963.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1977.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/1981.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2001.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2017.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2021.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2027.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2083.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2089.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2095.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2108.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2117.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2123.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2127.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2135.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2136.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2137.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2139.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2141.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2145.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2181.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2193.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2230.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2231.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2244.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2255.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2262.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2281.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2295.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2299.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2300.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2303.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2304.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2307.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2320.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2342.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2347.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2350.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2353.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2360.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2362.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2375.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2378.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2388.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2393.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2404.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2456.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2464.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2467.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2473.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2603.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2608.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2613.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2615.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2616.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2629.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2640.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2668.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2732.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2733.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2734.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2750.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2817.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2836.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2837.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2928.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2983.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/2995.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/3000.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/3004.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/3008.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/335.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/348.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/38.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/545.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/808_2411.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/846.v delete mode 100644 test-suite/bugs/closed/shouldsucceed/931.v create mode 100644 test-suite/bugs/opened/1338.v-disabled create mode 100644 test-suite/bugs/opened/1501.v create mode 100644 test-suite/bugs/opened/1596.v create mode 100644 test-suite/bugs/opened/1671.v delete mode 100644 test-suite/bugs/opened/1773.v create mode 100644 test-suite/bugs/opened/1811.v create mode 100644 test-suite/bugs/opened/2572.v-disabled create mode 100644 test-suite/bugs/opened/2652a.v-disabled create mode 100644 test-suite/bugs/opened/2652b.v-disabled create mode 100644 test-suite/bugs/opened/2800.v create mode 100644 test-suite/bugs/opened/2814.v create mode 100644 test-suite/bugs/opened/2951.v create mode 100644 test-suite/bugs/opened/3010.v-disabled create mode 100644 test-suite/bugs/opened/3045.v create mode 100644 test-suite/bugs/opened/3071.v create mode 100644 test-suite/bugs/opened/3092.v create mode 100644 test-suite/bugs/opened/3100.v create mode 100644 test-suite/bugs/opened/3166.v create mode 100644 test-suite/bugs/opened/3186.v-disabled create mode 100644 test-suite/bugs/opened/3209.v create mode 100644 test-suite/bugs/opened/3230.v create mode 100644 test-suite/bugs/opened/3248.v create mode 100644 test-suite/bugs/opened/3263.v create mode 100644 test-suite/bugs/opened/3277.v create mode 100644 test-suite/bugs/opened/3278.v create mode 100644 test-suite/bugs/opened/3283.v create mode 100644 test-suite/bugs/opened/3295.v create mode 100644 test-suite/bugs/opened/3298.v create mode 100644 test-suite/bugs/opened/3304.v create mode 100644 test-suite/bugs/opened/3311.v create mode 100644 test-suite/bugs/opened/3312.v create mode 100644 test-suite/bugs/opened/3320.v create mode 100644 test-suite/bugs/opened/3326.v create mode 100644 test-suite/bugs/opened/3343.v create mode 100644 test-suite/bugs/opened/3345.v create mode 100644 test-suite/bugs/opened/3357.v create mode 100644 test-suite/bugs/opened/3363.v create mode 100644 test-suite/bugs/opened/3370.v create mode 100644 test-suite/bugs/opened/3383.v create mode 100644 test-suite/bugs/opened/3395.v create mode 100644 test-suite/bugs/opened/3410.v create mode 100644 test-suite/bugs/opened/3459.v create mode 100644 test-suite/bugs/opened/3461.v create mode 100644 test-suite/bugs/opened/3463.v create mode 100644 test-suite/bugs/opened/3467.v create mode 100644 test-suite/bugs/opened/3478.v-disabled create mode 100644 test-suite/bugs/opened/3490.v create mode 100644 test-suite/bugs/opened/3491.v create mode 100644 test-suite/bugs/opened/3509.v create mode 100644 test-suite/bugs/opened/3510.v create mode 100644 test-suite/bugs/opened/3554.v create mode 100644 test-suite/bugs/opened/3562.v create mode 100644 test-suite/bugs/opened/3626.v create mode 100644 test-suite/bugs/opened/3655.v create mode 100644 test-suite/bugs/opened/3657.v create mode 100644 test-suite/bugs/opened/3670.v create mode 100644 test-suite/bugs/opened/3675.v create mode 100644 test-suite/bugs/opened/3681.v create mode 100644 test-suite/bugs/opened/3685.v create mode 100644 test-suite/bugs/opened/3753.v create mode 100644 test-suite/bugs/opened/3754.v create mode 100644 test-suite/bugs/opened/3786.v create mode 100644 test-suite/bugs/opened/3788.v create mode 100644 test-suite/bugs/opened/3808.v create mode 100644 test-suite/bugs/opened/3819.v create mode 100644 test-suite/bugs/opened/3849.v create mode 100644 test-suite/bugs/opened/743.v create mode 100644 test-suite/bugs/opened/HoTT_coq_106.v create mode 100644 test-suite/bugs/opened/HoTT_coq_120.v delete mode 100644 test-suite/bugs/opened/shouldnotfail/1338.v-disabled delete mode 100644 test-suite/bugs/opened/shouldnotfail/1501.v delete mode 100644 test-suite/bugs/opened/shouldnotfail/1596.v delete mode 100644 test-suite/bugs/opened/shouldnotfail/1671.v delete mode 100644 test-suite/bugs/opened/shouldnotfail/1811.v delete mode 100644 test-suite/bugs/opened/shouldnotfail/2310.v delete mode 100644 test-suite/bugs/opened/shouldnotfail/743.v create mode 100644 test-suite/coqchk/univ.v create mode 100644 test-suite/failure/circular_subtyping.v delete mode 100644 test-suite/failure/circular_subtyping1.v delete mode 100644 test-suite/failure/circular_subtyping2.v create mode 100644 test-suite/failure/cofixpoint.v create mode 100644 test-suite/failure/guard-cofix.v create mode 100644 test-suite/failure/inductive.v delete mode 100644 test-suite/failure/inductive1.v delete mode 100644 test-suite/failure/inductive2.v delete mode 100644 test-suite/failure/inductive3.v delete mode 100644 test-suite/failure/inductive4.v create mode 100644 test-suite/failure/sortelim.v create mode 100644 test-suite/failure/subterm.v create mode 100644 test-suite/failure/subterm2.v create mode 100644 test-suite/failure/subterm3.v create mode 100644 test-suite/ide/blocking-futures.fake delete mode 100644 test-suite/ide/undo007.fake create mode 100644 test-suite/ide/undo020.fake create mode 100644 test-suite/ide/undo021.fake create mode 100644 test-suite/ide/undo022.fake create mode 100644 test-suite/interactive/ParalITP.v create mode 100755 test-suite/interactive/ParalITP_smallproofs.v create mode 100644 test-suite/output/SearchHead.out create mode 100644 test-suite/output/SearchHead.v create mode 100644 test-suite/output/names.out create mode 100644 test-suite/output/names.v create mode 100755 test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v create mode 100644 test-suite/success/Case20.v create mode 100644 test-suite/success/Case21.v create mode 100644 test-suite/success/Case22.v create mode 100644 test-suite/success/CaseInClause.v create mode 100644 test-suite/success/Cases-bug3758.v delete mode 100644 test-suite/success/LegacyField.v create mode 100644 test-suite/success/NumberScopes.v create mode 100644 test-suite/success/applyTC.v create mode 100644 test-suite/success/extraction_dep.v create mode 100644 test-suite/success/indelim.v delete mode 100644 test-suite/success/instantiate.v create mode 100644 test-suite/success/keyedrewrite.v create mode 100644 test-suite/success/letproj.v create mode 100644 test-suite/success/ltac_plus.v create mode 100644 test-suite/success/namedunivs.v create mode 100644 test-suite/success/paralleltac.v delete mode 100644 test-suite/success/params_ind.v create mode 100644 test-suite/success/primitiveproj.v create mode 100644 test-suite/success/rewrite_dep.v create mode 100644 test-suite/success/rewrite_strat.v create mode 100644 test-suite/success/setoid_unif.v create mode 100644 test-suite/success/somatching.v create mode 100644 test-suite/success/univscompute.v create mode 100644 test-suite/typeclasses/backtrack.v create mode 100644 test-suite/typeclasses/deftwice.v create mode 100644 test-suite/vio/seff.v create mode 100644 test-suite/vio/simple.v create mode 100644 test-suite/vio/univ_constraints_statements.v (limited to 'test-suite') diff --git a/test-suite/Makefile b/test-suite/Makefile index ae1562c7..4a3a287c 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -30,15 +30,11 @@ BIN := ../bin/ LIB := .. -ifeq ($(BEST),byte) - coqtop := $(BIN)coqtop.byte -boot -q -batch -I prerequisite - bincoqc := $(BIN)coqc -coqlib $(LIB) -byte -I prerequisite -else - coqtop := $(BIN)coqtop -boot -q -batch -I prerequisite - bincoqc := $(BIN)coqc -coqlib $(LIB) -I prerequisite -endif +coqtop := $(BIN)coqtop -boot -q -batch -R prerequisite TestSuite +bincoqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite +bincoqchk := $(BIN)coqchk -coqlib $(LIB) -R prerequisite TestSuite -command := $(coqtop) -top Top -load-vernac-source +command := $(coqtop) -top Top -async-proofs-cache force -load-vernac-source coqc := $(coqtop) -compile coqdep := $(BIN)coqdep -coqlib $(LIB) @@ -46,7 +42,16 @@ SHOW := $(if $(VERBOSE),@true,@echo) HIDE := $(if $(VERBOSE),,@) REDIR := $(if $(VERBOSE),,> /dev/null 2>&1) -bogomips := +# read out an emacs config and look for coq-prog-args; if such exists, return it +get_coq_prog_args_helper = sed -n s'/^.*coq-prog-args:[[:space:]]*(\([^)]*\)).*/\1/p' $(1) +get_coq_prog_args = $(strip $(filter-out "-emacs-U" "-emacs",$(shell $(call get_coq_prog_args_helper,$(1))))) +SINGLE_QUOTE=" +#" # double up on the quotes, in a comment, to appease the emacs syntax highlighter +# wrap the arguments in parens, but only if they exist +get_coq_prog_args_in_parens = $(subst $(SINGLE_QUOTE),,$(if $(call get_coq_prog_args,$(1)), ($(call get_coq_prog_args,$(1))))) + + +bogomips:= ifneq (,$(wildcard /proc/cpuinfo)) sedbogo := -e "s/bogomips.*: \([0-9]*\).*/\1/p" # i386, ppc sedbogo += -e "s/Cpu0Bogo.*: \([0-9]*\).*/\1/p" # sparc @@ -59,6 +64,8 @@ ifeq (,$(bogomips)) endif log_success = "==========> SUCCESS <==========" +log_segfault = "==========> FAILURE <==========" +log_anomaly = "==========> FAILURE <==========" log_failure = "==========> FAILURE <==========" log_intro = "==========> TESTING $(1) <==========" @@ -69,14 +76,13 @@ log_intro = "==========> TESTING $(1) <==========" # Apart so that it can be easily skipped with overriding COMPLEXITY := $(if $(bogomips),complexity) -BUGS := bugs/opened/shouldnotfail bugs/opened/shouldnotsucceed \ - bugs/closed/shouldsucceed bugs/closed/shouldfail +BUGS := bugs/opened bugs/closed VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ - interactive micromega $(COMPLEXITY) modules + interactive micromega $(COMPLEXITY) modules stm # All subsystems -SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide +SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk ####################################################################### # Phony targets @@ -93,11 +99,14 @@ bugs: $(BUGS) clean: rm -f trace lia.cache - $(SHOW) "RM <**/*.stamp> <**/*.vo> <**/*.log>" + $(SHOW) "RM <**/*.stamp> <**/*.vo> <**/*.vio> <**/*.log>" $(HIDE)find . \( \ - -name '*.stamp' -o -name '*.vo' -o -name '*.log' \ + -name '*.stamp' -o -name '*.vo' -o -name '*.vio' -o -name '*.log' \ \) -print0 | xargs -0 rm -f +distclean: clean + $(HIDE)find . -name '*.log' -print0 | xargs -0 rm -f + ####################################################################### # Per-subsystem targets ####################################################################### @@ -113,7 +122,7 @@ $(foreach S,$(VSUBSYSTEMS),$(eval $(call mkstamp,$(S)))) # Summary ####################################################################### -summary_dir = echo $(1); find $(2) -name '*.log' -print0 | xargs -0 -n 1 tail -n1 | sort -g +summary_dir = echo $(1); find $(2) -name '*.log' -print0 | xargs -0 -n 1 tail -n1 | sort .PHONY: summary summary.log @@ -129,7 +138,10 @@ summary: $(call summary_dir, "Miscellaneous tests", misc); \ $(call summary_dir, "Complexity tests", complexity); \ $(call summary_dir, "Module tests", modules); \ + $(call summary_dir, "STM tests", stm); \ $(call summary_dir, "IDE tests", ide); \ + $(call summary_dir, "VI tests", vio); \ + $(call summary_dir, "Coqchk tests", coqchk); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \ nb_tests=`expr $$nb_success + $$nb_failure`; \ @@ -152,32 +164,21 @@ summary.log: # All files are assumed to have <# of the bug>.v as a name -# Opened bugs that should not succeed (FIXME: there were no such tests -# at the time of writing this Makefile, but the possibility was in the -# original shellscript... so left it here, but untested) -$(addsuffix .log,$(wildcard bugs/opened/shouldnotsucceed/*.v)): %.v.log: %.v - @echo "TEST $<" - $(HIDE){ \ - $(call test_intro,$<); \ - $(command) "$<" 2>&1; R=$$?; times; \ - if [ $$R = 0 ]; then \ - echo $(log_success); \ - echo " $<...still active"; \ - else \ - echo $(log_failure); \ - echo " $<...Error! (bug seems to be closed, please check)"; - fi; - } > "$@" - # Opened bugs that should not fail -$(addsuffix .log,$(wildcard bugs/opened/shouldnotfail/*.v)): %.v.log: %.v - @echo "TEST $<" +$(addsuffix .log,$(wildcard bugs/opened/*.v)): %.v.log: %.v + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(command) "$<" 2>&1; R=$$?; times; \ - if [ $$R != 0 ]; then \ + $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...still active"; \ + elif [ $$R = 129 ]; then \ + echo $(log_anomaly); \ + echo " $<...still active"; \ + elif [ $$R = 139 ]; then \ + echo $(log_segfault); \ + echo " $<...still active"; \ else \ echo $(log_failure); \ echo " $<...Error! (bug seems to be closed, please check)"; \ @@ -185,11 +186,11 @@ $(addsuffix .log,$(wildcard bugs/opened/shouldnotfail/*.v)): %.v.log: %.v } > "$@" # Closed bugs that should succeed -$(addsuffix .log,$(wildcard bugs/closed/shouldsucceed/*.v)): %.v.log: %.v - @echo "TEST $<" +$(addsuffix .log,$(wildcard bugs/closed/*.v)): %.v.log: %.v + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(command) "$<" 2>&1; R=$$?; times; \ + $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -199,30 +200,15 @@ $(addsuffix .log,$(wildcard bugs/closed/shouldsucceed/*.v)): %.v.log: %.v fi; \ } > "$@" -# Closed bugs that should fail -$(addsuffix .log,$(wildcard bugs/closed/shouldfail/*.v)): %.v.log: %.v - @echo "TEST $<" - $(HIDE){ \ - echo $(call log_intro,$<); \ - $(command) "$<" 2>&1; R=$$?; times; \ - if [ $$R != 0 ]; then \ - echo $(log_success); \ - echo " $<...Ok"; \ - else \ - echo $(log_failure); \ - echo " $<...Error! (bug seems to be opened, please check)"; \ - fi; \ - } > "$@" - ####################################################################### # Other generic tests ####################################################################### $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v - @echo "TEST $<" + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqc) "$*" 2>&1; R=$$?; times; \ + $(coqc) "$*" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be prepared" ; \ @@ -233,11 +219,28 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v } > "$@" $(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %.v - @echo "TEST $<" + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" + $(HIDE){ \ + opts="$(if $(findstring modules/,$<),-R modules Mods -impredicative-set)"; \ + echo $(call log_intro,$<); \ + $(command) "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1; R=$$?; times; \ + if [ $$R = 0 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error! (should be accepted)"; \ + fi; \ + } > "$@" + +stm: $(wildcard stm/*.v:%.v=%.v.log) +$(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ - opts="$(if $(findstring modules/,$<),-I modules -impredicative-set)"; \ echo $(call log_intro,$<); \ - $(command) "$<" $$opts 2>&1; R=$$?; times; \ + $(coqc) "$*" $(call get_coq_prog_args,"$<") -async-proofs on \ + -async-proofs-private-flags fallback-to-lazy-if-marshal-error=no,fallback-to-lazy-if-slave-dies=no \ + $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -248,11 +251,11 @@ $(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %. } > "$@" $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v - @echo "TEST $<" + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(command) "$<" 2>&1; R=$$?; times; \ - if [ $$R != 0 ]; then \ + $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ else \ @@ -261,13 +264,14 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v fi; \ } > "$@" -$(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v - @echo "TEST $<" +$(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \ - $(command) "$<" 2>&1 \ + $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1 \ | grep -v "Welcome to Coq" \ + | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ > $$tmpoutput; \ diff -u $*.out $$tmpoutput 2>&1; R=$$?; times; \ @@ -282,10 +286,10 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v } > "$@" $(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v - @echo "TEST $<" + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtop) < "$<" 2>&1; R=$$?; times; \ + $(coqtop) $(call get_coq_prog_args,"$<") < "$<" 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -300,11 +304,11 @@ $(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v # time is a 6120 bogomips cpu. ifneq (,$(bogomips)) $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v - @echo "TEST $<" + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ true "extract effective user time"; \ - res=`$(command) "$<" 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \ + res=`$(command) "$<" $(call get_coq_prog_args,"$<") 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \ R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ @@ -331,10 +335,10 @@ endif # Ideal-features tests $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v - @echo "TEST $<" + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(command) "$<" 2>&1; R=$$?; times; \ + $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_success); \ echo " $<...still wished"; \ @@ -346,35 +350,17 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v # Additionnal dependencies for module tests $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo -%.vo: %.v - $(HIDE)$(coqtop) -compile $* +modules/%.vo: modules/%.v + $(HIDE)$(coqtop) -R modules Mods -compile $(<:.v=) ####################################################################### # Miscellaneous tests ####################################################################### -misc: misc/xml.log misc/deps-order.log misc/universes.log +misc: misc/deps-order.log misc/universes.log -# Test xml compilation -xml: misc/xml.log -misc/xml.log: - @echo "TEST misc/xml" - $(HIDE){ \ - echo $(call log_intro,xml); \ - rm -rf misc/xml; \ - COQ_XML_LIBRARY_ROOT=misc/xml \ - $(bincoqc) -xml misc/berardi_test 2>&1; times; \ - if [ ! -d misc/xml ]; then \ - echo $(log_failure); \ - echo " misc/xml... failed"; \ - else \ - echo $(log_success); \ - echo " misc/xml...apparently ok"; \ - fi; rm -rf misc/xml; \ - } > "$@" - -# Check that both coqdep and coqtop/coqc takes the later -I/-R -# Check that both coqdep and coqtop/coqc supports both -R and -I dir -as lib +# Check that both coqdep and coqtop/coqc supports -R +# Check that both coqdep and coqtop/coqc takes the later -R # See bugs 2242, 2337, 2339 deps-order: misc/deps-order.log misc/deps-order.log: @@ -383,12 +369,12 @@ misc/deps-order.log: echo $(call log_intro,deps-order); \ rm -f misc/deps/*/*.vo; \ tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \ - $(coqdep) -I misc/deps/lib -as lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 \ + $(coqdep) -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 \ | head -n 1 > $$tmpoutput; \ diff -u misc/deps/deps.out $$tmpoutput 2>&1; R=$$?; times; \ - $(bincoqc) -I misc/deps/lib -as lib misc/deps/lib/foo.v 2>&1; \ - $(bincoqc) -I misc/deps/lib -as lib -R misc/deps/client client misc/deps/client/foo.v 2>&1; \ - $(coqtop) -I misc/deps/lib -as lib -R misc/deps/client client -load-vernac-source misc/deps/client/bar.v 2>&1; \ + $(bincoqc) -R misc/deps/lib lib misc/deps/lib/foo.v 2>&1; \ + $(bincoqc) -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/foo.v 2>&1; \ + $(coqtop) -R misc/deps/lib lib -R misc/deps/client client -load-vernac-source misc/deps/client/bar.v 2>&1; \ S=$$?; times; \ if [ $$R = 0 -a $$S = 0 ]; then \ echo $(log_success); \ @@ -406,8 +392,8 @@ universes: misc/universes.log misc/universes.log: misc/universes/all_stdlib.v @echo "TEST misc/universes" $(HIDE){ \ - $(bincoqc) -I misc/universes misc/universes/all_stdlib 2>&1; \ - $(bincoqc) -I misc/universes misc/universes/universes 2>&1; \ + $(bincoqc) -R misc/universes Universes misc/universes/all_stdlib 2>&1; \ + $(bincoqc) -R misc/universes Universes misc/universes/universes 2>&1; \ mv universes.txt misc/universes; \ N=`awk '{print $$3}' misc/universes/universes.txt | sort -u | wc -l`; \ times; \ @@ -432,7 +418,7 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake)) @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ - $(BIN)fake_ide "$(BIN)coqtop -boot" < $< 2>&1; \ + $(BIN)fake_ide $< "$(BIN)coqtop -boot -async-proofs on" 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -441,3 +427,37 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake)) echo " $<...Error!"; \ fi; \ } > "$@" + +vio: $(patsubst %.v,%.vio.log,$(wildcard vio/*.v)) + +%.vio.log:%.v + @echo "TEST $<" + $(HIDE){ \ + $(bincoqc) -quick -R vio vio $* 2>&1 && \ + $(coqtop) -R vio vio -vio2vo $*.vio 2>&1 && \ + $(bincoqchk) -R vio vio -norec $(subst /,.,$*) 2>&1; \ + if [ $$? = 0 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error!"; \ + fi; \ + } > "$@" + +coqchk: $(patsubst %.v,%.chk.log,$(wildcard coqchk/*.v)) + +%.chk.log:%.v + @echo "TEST $<" + $(HIDE){ \ + $(bincoqc) -R coqchk coqchk $* 2>&1 && \ + $(bincoqchk) -R coqchk coqchk -norec $(subst /,.,$*) 2>&1; \ + if [ $$? = 0 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error!"; \ + fi; \ + } > "$@" + diff --git a/test-suite/bench/lists-100.v b/test-suite/bench/lists-100.v index 92e50dba..352c7cea 100644 --- a/test-suite/bench/lists-100.v +++ b/test-suite/bench/lists-100.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop. + +Definition myFact := forall x, P x. + +Hint Extern 1 (P _) => progress (unfold myFact in *). + +Lemma test : (True -> myFact) -> P 3. +Proof. + intros. debug eauto. +Qed. diff --git a/test-suite/bugs/closed/1100.v b/test-suite/bugs/closed/1100.v new file mode 100644 index 00000000..32c78b4b --- /dev/null +++ b/test-suite/bugs/closed/1100.v @@ -0,0 +1,12 @@ +Require Import Setoid. + +Parameter P : nat -> Prop. +Parameter Q : nat -> Prop. +Parameter PQ : forall n, P n <-> Q n. + +Lemma PQ2 : forall n, P n -> Q n. + intros. + rewrite PQ in H. + trivial. +Qed. + diff --git a/test-suite/bugs/closed/121.v b/test-suite/bugs/closed/121.v new file mode 100644 index 00000000..8c5a3885 --- /dev/null +++ b/test-suite/bugs/closed/121.v @@ -0,0 +1,17 @@ +Require Import Setoid. + +Section Setoid_Bug. + +Variable X:Type -> Type. +Variable Xeq : forall A, (X A) -> (X A) -> Prop. +Hypothesis Xst : forall A, Equivalence (Xeq A). + +Variable map : forall A B, (A -> B) -> X A -> X B. + +Implicit Arguments map [A B]. + +Goal forall A B (a b:X (B -> A)) (c:X A) (f:A -> B -> A), Xeq _ a b -> Xeq _ b (map f c) -> Xeq _ a (map f c). +intros A B a b c f Hab Hbc. +rewrite Hab. +assumption. +Qed. diff --git a/test-suite/bugs/closed/1243.v b/test-suite/bugs/closed/1243.v new file mode 100644 index 00000000..7d6781db --- /dev/null +++ b/test-suite/bugs/closed/1243.v @@ -0,0 +1,12 @@ +Require Import ZArith. +Require Import Arith. +Open Scope Z_scope. + +Theorem r_ex : (forall x y:nat, x + y = x + y)%nat. +Admitted. + +Theorem r_ex' : forall x y:nat, (x + y = x + y)%nat. +Admitted. + + + diff --git a/test-suite/bugs/closed/1302.v b/test-suite/bugs/closed/1302.v new file mode 100644 index 00000000..e94dfcfb --- /dev/null +++ b/test-suite/bugs/closed/1302.v @@ -0,0 +1,22 @@ +Module Type T. + +Parameter A : Type. + +Inductive L : Type := +| L0 : L (* without this constructor, it works right *) +| L1 : A -> L. + +End T. + +Axiom Tp : Type. + +Module TT : T. + +Definition A : Type := Tp. + +Inductive L : Type := +| L0 : L +| L1 : A -> L. + +End TT. + diff --git a/test-suite/bugs/closed/1322.v b/test-suite/bugs/closed/1322.v new file mode 100644 index 00000000..1ec7d452 --- /dev/null +++ b/test-suite/bugs/closed/1322.v @@ -0,0 +1,24 @@ +Require Import Setoid. + +Section transition_gen. + +Variable I : Type. +Variable I_eq :I -> I -> Prop. +Variable I_eq_equiv : Setoid_Theory I I_eq. + +(* Add Relation I I_eq + reflexivity proved by I_eq_equiv.(Seq_refl I I_eq) + symmetry proved by I_eq_equiv.(Seq_sym I I_eq) + transitivity proved by I_eq_equiv.(Seq_trans I I_eq) +as I_eq_relation. *) + +Add Setoid I I_eq I_eq_equiv as I_with_eq. + +Variable F : I -> Type. +Variable F_morphism : forall i j, I_eq i j -> F i = F j. + + +Add Morphism F with signature I_eq ==> (@eq _) as F_morphism2. +Admitted. + +End transition_gen. diff --git a/test-suite/bugs/closed/1411.v b/test-suite/bugs/closed/1411.v new file mode 100644 index 00000000..a1a7b288 --- /dev/null +++ b/test-suite/bugs/closed/1411.v @@ -0,0 +1,35 @@ +Require Import List. +Require Import Program. + +Inductive Tree : Set := +| Br : Tree -> Tree -> Tree +| No : nat -> Tree +. + +(* given a tree, we want to know which lists can + be used to navigate exactly to a node *) +Inductive Exact : Tree -> list bool -> Prop := +| exDone n : Exact (No n) nil +| exLeft l r p: Exact l p -> Exact (Br l r) (true::p) +| exRight l r p: Exact r p -> Exact (Br l r) (false::p) +. + +Definition unreachable A : False -> A. +intros. +destruct H. +Defined. + +Program Fixpoint fetch t p (x:Exact t p) {struct t} := + match t, p with + | No p' , nil => p' + | No p' , _::_ => unreachable nat _ + | Br l r, nil => unreachable nat _ + | Br l r, true::t => fetch l t _ + | Br l r, false::t => fetch r t _ + end. + +Next Obligation. inversion x. Qed. +Next Obligation. inversion x. Qed. +Next Obligation. inversion x; trivial. Qed. +Next Obligation. inversion x; trivial. Qed. + diff --git a/test-suite/bugs/closed/1414.v b/test-suite/bugs/closed/1414.v new file mode 100644 index 00000000..ee9e2504 --- /dev/null +++ b/test-suite/bugs/closed/1414.v @@ -0,0 +1,40 @@ +Require Import ZArith Coq.Program.Wf Coq.Program.Utils. + +Parameter data:Set. + +Inductive t : Set := + | Leaf : t + | Node : t -> data -> t -> Z -> t. + +Parameter avl : t -> Prop. +Parameter bst : t -> Prop. +Parameter In : data -> t -> Prop. +Parameter cardinal : t -> nat. +Definition card2 (s:t*t) := let (s1,s2) := s in cardinal s1 + cardinal s2. + +Parameter split : data -> t -> t*(bool*t). +Parameter join : t -> data -> t -> t. +Parameter add : data -> t -> t. + +Program Fixpoint union + (s u:t) + (hb1: bst s)(ha1: avl s)(hb2: bst u)(hb2: avl u) + { measure (cardinal s + cardinal u) } : + {s' : t | bst s' /\ avl s' /\ forall x, In x s' <-> In x s \/ In x u} := + match s, u with + | Leaf,t2 => t2 + | t1,Leaf => t1 + | Node l1 v1 r1 h1, Node l2 v2 r2 h2 => + if (Z_ge_lt_dec h1 h2) then + if (Z.eq_dec h2 1) + then add v2 s + else + let (l2', r2') := split v1 u in + join (union l1 l2' _ _ _ _) v1 (union r1 (snd r2') _ _ _ _) + else + if (Z.eq_dec h1 1) + then add v1 s + else + let (l1', r1') := split v2 u in + join (union l1' l2 _ _ _ _) v2 (union (snd r1') r2 _ _ _ _) + end. diff --git a/test-suite/bugs/closed/1416.v b/test-suite/bugs/closed/1416.v new file mode 100644 index 00000000..ee092005 --- /dev/null +++ b/test-suite/bugs/closed/1416.v @@ -0,0 +1,30 @@ +(* In 8.1 autorewrite used to raised an anomaly here *) +(* After resolution of the bug, autorewrite succeeded *) +(* From forthcoming 8.4, autorewrite is forbidden to instantiate *) +(* evars, so the new test just checks it is not an anomaly *) + +Set Implicit Arguments. + +Record Place (Env A: Type) : Type := { + read: Env -> A ; + write: Env -> A -> Env ; + write_read: forall (e:Env), (write e (read e))=e +}. + +Hint Rewrite -> write_read: placeeq. + +Record sumPl (Env A B: Type) (vL:(Place Env A)) (vR:(Place Env B)) : Type := + { + mkEnv: A -> B -> Env ; + mkEnv2writeL: forall (e:Env) (x:A), (mkEnv x (read vR e))=(write vL e x) + }. + +(* when the following line is commented, the bug does not appear *) +Hint Rewrite -> mkEnv2writeL: placeeq. + +Lemma autorewrite_raise_anomaly: forall (Env A:Type) (e: Env) (p:Place Env A), + (exists e1:Env, e=(write p e1 (read p e))). +Proof. + intros Env A e p; eapply ex_intro. + autorewrite with placeeq. (* Here is the bug *) + diff --git a/test-suite/bugs/closed/1419.v b/test-suite/bugs/closed/1419.v new file mode 100644 index 00000000..d021107d --- /dev/null +++ b/test-suite/bugs/closed/1419.v @@ -0,0 +1,8 @@ +Goal True. + set(a := 0). + set(b := a). + unfold a in b. + clear a. + Eval vm_compute in b. + trivial. +Qed. diff --git a/test-suite/bugs/closed/1425.v b/test-suite/bugs/closed/1425.v new file mode 100644 index 00000000..6be30174 --- /dev/null +++ b/test-suite/bugs/closed/1425.v @@ -0,0 +1,19 @@ +Require Import Setoid. + +Parameter recursion : forall A : Set, A -> (nat -> A -> A) -> nat -> A. + +Axiom recursion_S : + forall (A : Set) (EA : relation A) (a : A) (f : nat -> A -> A) (n : nat), + EA (recursion A a f (S n)) (f n (recursion A a f n)). + +Goal forall n : nat, recursion nat 0 (fun _ _ => 1) (S n) = 1. +intro n. +rewrite recursion_S. +reflexivity. +Qed. + +Goal forall n : nat, recursion nat 0 (fun _ _ => 1) (S n) = 1. +intro n. +setoid_rewrite recursion_S. +reflexivity. +Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/1446.v b/test-suite/bugs/closed/1446.v new file mode 100644 index 00000000..8cb2d653 --- /dev/null +++ b/test-suite/bugs/closed/1446.v @@ -0,0 +1,20 @@ +Lemma not_true_eq_false : forall (b:bool), b <> true -> b = false. +Proof. + destruct b;intros;trivial. + elim H. + exact (refl_equal true). +Qed. + +Section BUG. + + Variable b : bool. + Hypothesis H : b <> true. + Hypothesis H0 : b = true. + Hypothesis H1 : b <> true. + + Goal False. + rewrite (not_true_eq_false _ H) in * |-. + contradiction. + Qed. + +End BUG. diff --git a/test-suite/bugs/closed/1448.v b/test-suite/bugs/closed/1448.v new file mode 100644 index 00000000..fe3b4c8b --- /dev/null +++ b/test-suite/bugs/closed/1448.v @@ -0,0 +1,28 @@ +Require Import Relations. +Require Import Setoid. +Require Import Ring_theory. +Require Import Ring_base. + + +Variable R : Type. +Variable Rone Rzero : R. +Variable Rplus Rmult Rminus : R -> R -> R. +Variable Rneg : R -> R. + +Lemma my_ring_theory : @ring_theory R Rzero Rone Rplus Rmult Rminus Rneg (@eq +R). +Admitted. + +Variable Req : R -> R -> Prop. + +Hypothesis Req_refl : reflexive _ Req. +Hypothesis Req_sym : symmetric _ Req. +Hypothesis Req_trans : transitive _ Req. + +Add Relation R Req + reflexivity proved by Req_refl + symmetry proved by Req_sym + transitivity proved by Req_trans + as Req_rel. + +Add Ring my_ring : my_ring_theory (abstract). diff --git a/test-suite/bugs/closed/1477.v b/test-suite/bugs/closed/1477.v new file mode 100644 index 00000000..dfc8c328 --- /dev/null +++ b/test-suite/bugs/closed/1477.v @@ -0,0 +1,18 @@ +Inductive I : Set := + | A : nat -> nat -> I + | B : nat -> nat -> I. + +Definition foo1 (x:I) : nat := + match x with + | A a b | B a b => S b + end. + +Definition foo2 (x:I) : nat := + match x with + | A _ b | B b _ => S b + end. + +Definition foo (x:I) : nat := + match x with + | A a b | B b a => S b + end. diff --git a/test-suite/bugs/closed/1483.v b/test-suite/bugs/closed/1483.v new file mode 100644 index 00000000..a3d7f168 --- /dev/null +++ b/test-suite/bugs/closed/1483.v @@ -0,0 +1,10 @@ +Require Import BinPos. + +Definition P := (fun x : positive => x = xH). + +Goal forall (p q : positive), P q -> q = p -> P p. +intros; congruence. +Qed. + + + diff --git a/test-suite/bugs/closed/1507.v b/test-suite/bugs/closed/1507.v new file mode 100644 index 00000000..f2ab9100 --- /dev/null +++ b/test-suite/bugs/closed/1507.v @@ -0,0 +1,120 @@ +(* + Implementing reals a la Stolzenberg + + Danko Ilik, March 2007 + + XField.v -- (unfinished) axiomatisation of the theories of real and + rational intervals. +*) + +Definition associative (A:Type)(op:A->A->A) := + forall x y z:A, op (op x y) z = op x (op y z). + +Definition commutative (A:Type)(op:A->A->A) := + forall x y:A, op x y = op y x. + +Definition trichotomous (A:Type)(R:A->A->Prop) := + forall x y:A, R x y \/ x=y \/ R y x. + +Definition relation (A:Type) := A -> A -> Prop. +Definition reflexive (A:Type)(R:relation A) := forall x:A, R x x. +Definition transitive (A:Type)(R:relation A) := + forall x y z:A, R x y -> R y z -> R x z. +Definition symmetric (A:Type)(R:relation A) := forall x y:A, R x y -> R y x. + +Record interval (X:Set)(le:X->X->Prop) : Set := + interval_make { + interval_left : X; + interval_right : X; + interval_nonempty : le interval_left interval_right + }. + +Record I (grnd:Set)(le:grnd->grnd->Prop) : Type := Imake { + Icar := interval grnd le; + Iplus : Icar -> Icar -> Icar; + Imult : Icar -> Icar -> Icar; + Izero : Icar; + Ione : Icar; + Iopp : Icar -> Icar; + Iinv : Icar -> Icar; + Ic : Icar -> Icar -> Prop; (* consistency *) + (* monoids *) + Iplus_assoc : associative Icar Iplus; + Imult_assoc : associative Icar Imult; + (* abelian groups *) + Iplus_comm : commutative Icar Iplus; + Imult_comm : commutative Icar Imult; + Iplus_0_l : forall x:Icar, Ic (Iplus Izero x) x; + Iplus_0_r : forall x:Icar, Ic (Iplus x Izero) x; + Imult_0_l : forall x:Icar, Ic (Imult Ione x) x; + Imult_0_r : forall x:Icar, Ic (Imult x Ione) x; + Iplus_opp_r : forall x:Icar, Ic (Iplus x (Iopp x)) (Izero); + Imult_inv_r : forall x:Icar, ~(Ic x Izero) -> Ic (Imult x (Iinv x)) Ione; + (* distributive laws *) + Imult_plus_distr_l : forall x x' y y' z z' z'', + Ic x x' -> Ic y y' -> Ic z z' -> Ic z z'' -> + Ic (Imult (Iplus x y) z) (Iplus (Imult x' z') (Imult y' z'')); + (* order and lattice structure *) + Ilt : Icar -> Icar -> Prop; + Ilc := fun (x y:Icar) => Ilt x y \/ Ic x y; + Isup : Icar -> Icar -> Icar; + Iinf : Icar -> Icar -> Icar; + Ilt_trans : transitive _ lt; + Ilt_trich : forall x y:Icar, Ilt x y \/ Ic x y \/ Ilt y x; + Isup_lub : forall x y z:Icar, Ilc x z -> Ilc y z -> Ilc (Isup x y) z; + Iinf_glb : forall x y z:Icar, Ilc x y -> Ilc x z -> Ilc x (Iinf y z); + (* order preserves operations? *) + (* properties of Ic *) + Ic_refl : reflexive _ Ic; + Ic_sym : symmetric _ Ic +}. + +Definition interval_set (X:Set)(le:X->X->Prop) := + (interval X le) -> Prop. (* can be Set as well *) +Check interval_set. +Check Ic. +Definition consistent (X:Set)(le:X->X->Prop)(TI:I X le)(p:interval_set X le) := + forall I J:interval X le, p I -> p J -> (Ic X le TI) I J. +Check consistent. +(* define 'fine' *) + +Record N (grnd:Set)(le:grnd->grnd->Prop)(grndI:I grnd le) : Type := Nmake { + Ncar := interval_set grnd le; + Nplus : Ncar -> Ncar -> Ncar; + Nmult : Ncar -> Ncar -> Ncar; + Nzero : Ncar; + None : Ncar; + Nopp : Ncar -> Ncar; + Ninv : Ncar -> Ncar; + Nc : Ncar -> Ncar -> Prop; (* Ncistency *) + (* monoids *) + Nplus_assoc : associative Ncar Nplus; + Nmult_assoc : associative Ncar Nmult; + (* abelian groups *) + Nplus_comm : commutative Ncar Nplus; + Nmult_comm : commutative Ncar Nmult; + Nplus_0_l : forall x:Ncar, Nc (Nplus Nzero x) x; + Nplus_0_r : forall x:Ncar, Nc (Nplus x Nzero) x; + Nmult_0_l : forall x:Ncar, Nc (Nmult None x) x; + Nmult_0_r : forall x:Ncar, Nc (Nmult x None) x; + Nplus_opp_r : forall x:Ncar, Nc (Nplus x (Nopp x)) (Nzero); + Nmult_inv_r : forall x:Ncar, ~(Nc x Nzero) -> Nc (Nmult x (Ninv x)) None; + (* distributive laws *) + Nmult_plus_distr_l : forall x x' y y' z z' z'', + Nc x x' -> Nc y y' -> Nc z z' -> Nc z z'' -> + Nc (Nmult (Nplus x y) z) (Nplus (Nmult x' z') (Nmult y' z'')); + (* order and lattice structure *) + Nlt : Ncar -> Ncar -> Prop; + Nlc := fun (x y:Ncar) => Nlt x y \/ Nc x y; + Nsup : Ncar -> Ncar -> Ncar; + Ninf : Ncar -> Ncar -> Ncar; + Nlt_trans : transitive _ lt; + Nlt_trich : forall x y:Ncar, Nlt x y \/ Nc x y \/ Nlt y x; + Nsup_lub : forall x y z:Ncar, Nlc x z -> Nlc y z -> Nlc (Nsup x y) z; + Ninf_glb : forall x y z:Ncar, Nlc x y -> Nlc x z -> Nlc x (Ninf y z); + (* order preserves operations? *) + (* properties of Nc *) + Nc_refl : reflexive _ Nc; + Nc_sym : symmetric _ Nc +}. + diff --git a/test-suite/bugs/closed/1568.v b/test-suite/bugs/closed/1568.v new file mode 100644 index 00000000..3609e9c8 --- /dev/null +++ b/test-suite/bugs/closed/1568.v @@ -0,0 +1,13 @@ +CoInductive A: Set := + mk_A: B -> A +with B: Set := + mk_B: A -> B. + +CoFixpoint a:A := mk_A b +with b:B := mk_B a. + +Goal b = match a with mk_A a1 => a1 end. + simpl. reflexivity. +Qed. + + diff --git a/test-suite/bugs/closed/1576.v b/test-suite/bugs/closed/1576.v new file mode 100644 index 00000000..3621f7a1 --- /dev/null +++ b/test-suite/bugs/closed/1576.v @@ -0,0 +1,38 @@ +Module Type TA. +Parameter t : Set. +End TA. + +Module Type TB. +Declare Module A: TA. +End TB. + +Module Type TC. +Declare Module B : TB. +End TC. + +Module Type TD. + +Declare Module B: TB . +Declare Module C: TC + with Module B := B . +End TD. + +Module Type TE. +Declare Module D : TD. +End TE. + +Module Type TF. +Declare Module E: TE. +End TF. + +Module G (D: TD). +Module B' := D.C.B. +End G. + +Module H (F: TF). +Module I := G(F.E.D). +End H. + +Declare Module F: TF. +Module K := H(F). + diff --git a/test-suite/bugs/closed/1582.v b/test-suite/bugs/closed/1582.v new file mode 100644 index 00000000..be5d3dd2 --- /dev/null +++ b/test-suite/bugs/closed/1582.v @@ -0,0 +1,15 @@ +Require Import Peano_dec. + +Definition fact_F : + forall (n:nat), + (forall m, m nat) -> + nat. +refine + (fun n fact_rec => + if eq_nat_dec n 0 then + 1 + else + let fn := fact_rec (n-1) _ in + n * fn). +Admitted. + diff --git a/test-suite/bugs/closed/1604.v b/test-suite/bugs/closed/1604.v new file mode 100644 index 00000000..22c3df82 --- /dev/null +++ b/test-suite/bugs/closed/1604.v @@ -0,0 +1,7 @@ +Require Import Setoid. + +Parameter F : nat -> nat. +Axiom F_id : forall n : nat, n = F n. +Goal forall n : nat, F n = n. +intro n. setoid_rewrite F_id at 3. reflexivity. +Qed. diff --git a/test-suite/bugs/closed/1614.v b/test-suite/bugs/closed/1614.v new file mode 100644 index 00000000..6bc165d4 --- /dev/null +++ b/test-suite/bugs/closed/1614.v @@ -0,0 +1,21 @@ +Require Import Ring. +Require Import ArithRing. + +Fixpoint eq_nat_bool (x y : nat) {struct x} : bool := +match x, y with +| 0, 0 => true +| S x', S y' => eq_nat_bool x' y' +| _, _ => false +end. + +Theorem eq_nat_bool_implies_eq : forall x y, eq_nat_bool x y = true -> x = y. +Proof. +induction x; destruct y; simpl; intro H; try (reflexivity || inversion H). +apply IHx in H; rewrite H; reflexivity. +Qed. + +Add Ring MyNatSRing : natSRth (decidable eq_nat_bool_implies_eq). + +Goal 0 = 0. + ring. +Qed. diff --git a/test-suite/bugs/closed/1618.v b/test-suite/bugs/closed/1618.v new file mode 100644 index 00000000..a9b067ce --- /dev/null +++ b/test-suite/bugs/closed/1618.v @@ -0,0 +1,23 @@ +Inductive A: Set := +| A1: nat -> A. + +Definition A_size (a: A) : nat := + match a with + | A1 n => 0 + end. + +Require Import Recdef. + +Function n3 (P: A -> Prop) (f: forall n, P (A1 n)) (a: A) {struct a} : P a := + match a return (P a) with + | A1 n => f n + end. + + +Function n1 (P: A -> Prop) (f: forall n, P (A1 n)) (a: A) {measure A_size a} : +P +a := + match a return (P a) with + | A1 n => f n + end. + diff --git a/test-suite/bugs/closed/1634.v b/test-suite/bugs/closed/1634.v new file mode 100644 index 00000000..0150c250 --- /dev/null +++ b/test-suite/bugs/closed/1634.v @@ -0,0 +1,24 @@ +Require Export Relation_Definitions. +Require Export Setoid. + +Variable A : Type. +Variable S : A -> Type. +Variable Seq : forall {a:A}, relation (S a). + +Hypothesis Seq_refl : forall {a:A} (x : S a), Seq x x. +Hypothesis Seq_sym : forall {a:A} (x y : S a), Seq x y -> Seq y x. +Hypothesis Seq_trans : forall {a:A} (x y z : S a), Seq x y -> Seq y z -> +Seq x z. + +Add Parametric Relation a : (S a) Seq + reflexivity proved by Seq_refl + symmetry proved by Seq_sym + transitivity proved by Seq_trans + as S_Setoid. + +Goal forall (a : A) (x y : S a), Seq x y -> Seq x y. + intros a x y H. + setoid_replace x with y. + reflexivity. + trivial. +Qed. diff --git a/test-suite/bugs/closed/1643.v b/test-suite/bugs/closed/1643.v new file mode 100644 index 00000000..879a65b1 --- /dev/null +++ b/test-suite/bugs/closed/1643.v @@ -0,0 +1,20 @@ +(* Check some aspects of that the algorithm used to possibly reuse a + global name in the recursive calls (coinductive case) *) + +CoInductive Str : Set := Cons (h:nat) (t:Str). + +Definition decomp_func (s:Str) := + match s with + | Cons h t => Cons h t + end. + +Theorem decomp s: s = decomp_func s. +Proof. + case s; simpl; reflexivity. +Qed. + +Definition zeros := (cofix z : Str := Cons 0 z). +Lemma zeros_rw : zeros = Cons 0 zeros. + rewrite (decomp zeros). + simpl. +Admitted. diff --git a/test-suite/bugs/closed/1680.v b/test-suite/bugs/closed/1680.v new file mode 100644 index 00000000..524c7bab --- /dev/null +++ b/test-suite/bugs/closed/1680.v @@ -0,0 +1,9 @@ +Ltac int1 := let h := fresh in intro h. + +Goal nat -> nat -> True. + let h' := fresh in (let h := fresh in intro h); intro h'. + Restart. let h' := fresh in int1; intro h'. + trivial. +Qed. + + diff --git a/test-suite/bugs/closed/1683.v b/test-suite/bugs/closed/1683.v new file mode 100644 index 00000000..3e99694b --- /dev/null +++ b/test-suite/bugs/closed/1683.v @@ -0,0 +1,42 @@ +Require Import Setoid. + +Section SetoidBug. + +Variable ms : Type. +Variable ms_type : ms -> Type. +Variable ms_eq : forall (A:ms), relation (ms_type A). + +Variable CR : ms. + +Record Ring : Type := +{Ring_type : Type}. + +Variable foo : forall (A:Ring), nat -> Ring_type A. +Variable IR : Ring. +Variable IRasCR : Ring_type IR -> ms_type CR. + +Definition CRasCRing : Ring := Build_Ring (ms_type CR). + +Hypothesis ms_refl : forall A x, ms_eq A x x. +Hypothesis ms_sym : forall A x y, ms_eq A x y -> ms_eq A y x. +Hypothesis ms_trans : forall A x y z, ms_eq A x y -> ms_eq A y z -> ms_eq A x z. + +Add Parametric Relation A : (ms_type A) (ms_eq A) + reflexivity proved by (ms_refl A) + symmetry proved by (ms_sym A) + transitivity proved by (ms_trans A) + as ms_Setoid. + +Hypothesis foobar : forall n, ms_eq CR (IRasCR (foo IR n)) (foo CRasCRing n). + +Goal forall (b:ms_type CR), + ms_eq CR (IRasCR (foo IR O)) b -> + ms_eq CR (IRasCR (foo IR O)) b. +intros b H. +rewrite foobar. +rewrite foobar in H. +assumption. +Qed. + + + diff --git a/test-suite/bugs/closed/1696.v b/test-suite/bugs/closed/1696.v new file mode 100644 index 00000000..0826428a --- /dev/null +++ b/test-suite/bugs/closed/1696.v @@ -0,0 +1,16 @@ +Require Import Setoid. + +Inductive mynat := z : mynat | s : mynat -> mynat. + +Parameter E : mynat -> mynat -> Prop. +Axiom E_equiv : equiv mynat E. + +Add Relation mynat E + reflexivity proved by (proj1 E_equiv) + symmetry proved by (proj2 (proj2 E_equiv)) + transitivity proved by (proj1 (proj2 E_equiv)) +as E_rel. + +Notation "x == y" := (E x y) (at level 70). + +Goal z == s z -> s z == z. intros H. setoid_rewrite H at 2. reflexivity. Qed. diff --git a/test-suite/bugs/closed/1703.v b/test-suite/bugs/closed/1703.v new file mode 100644 index 00000000..114e3185 --- /dev/null +++ b/test-suite/bugs/closed/1703.v @@ -0,0 +1,8 @@ +(* Check correct binding of intros until used in Ltac *) + +Ltac intros_until n := intros until n. + +Goal forall i j m n : nat, i = 0 /\ j = 0 /\ m = 0 /\ n = 0. +intro i. +Fail intros until i. +Abort. diff --git a/test-suite/bugs/closed/1704.v b/test-suite/bugs/closed/1704.v new file mode 100644 index 00000000..4b02d5f9 --- /dev/null +++ b/test-suite/bugs/closed/1704.v @@ -0,0 +1,17 @@ + +Require Import Setoid. +Parameter E : nat -> nat -> Prop. +Axiom E_equiv : equiv nat E. +Add Relation nat E +reflexivity proved by (proj1 E_equiv) +symmetry proved by (proj2 (proj2 E_equiv)) +transitivity proved by (proj1 (proj2 E_equiv)) +as E_rel. +Notation "x == y" := (E x y) (at level 70, no associativity). +Axiom r : False -> 0 == 1. +Goal 0 == 0. +Proof. +rewrite r. +reflexivity. +admit. +Qed. diff --git a/test-suite/bugs/closed/1711.v b/test-suite/bugs/closed/1711.v new file mode 100644 index 00000000..e16612e3 --- /dev/null +++ b/test-suite/bugs/closed/1711.v @@ -0,0 +1,34 @@ +(* Test for evar map consistency - was failing at some point and was *) +(* assumed to be solved from revision 10151 (but using a bad fix) *) + +Require Import List. +Set Implicit Arguments. + +Inductive rose : Set := Rose : nat -> list rose -> rose. + +Section RoseRec. +Variables (P: rose -> Set)(L: list rose -> Set). +Hypothesis + (R: forall n rs, L rs -> P (Rose n rs)) + (Lnil: L nil) + (Lcons: forall r rs, P r -> L rs -> L (cons r rs)). + +Fixpoint rose_rec2 (t:rose) {struct t} : P t := + match t as x return P x with + | Rose n rs => + R n ((fix rs_ind (l' : list rose): L l' := + match l' as x return L x with + | nil => Lnil + | cons t tl => Lcons (rose_rec2 t) (rs_ind tl) + end) + rs) + end. +End RoseRec. + +Lemma rose_map : rose -> rose. +Proof. intro H; elim H using rose_rec2 with + (L:=fun _ => list rose); (* was assumed to fail here *) +(* (L:=fun (_:list rose) => list rose); *) + clear H; simpl; intros. + exact (Rose n rs). exact nil. exact (H::H0). +Defined. diff --git a/test-suite/bugs/closed/1718.v b/test-suite/bugs/closed/1718.v new file mode 100644 index 00000000..715fa941 --- /dev/null +++ b/test-suite/bugs/closed/1718.v @@ -0,0 +1,9 @@ +(* lazy delta unfolding used to miss delta on rels and vars (fixed in 10172) *) + +Check + let g := fun _ => 0 in + fix f (n : nat) := + match n with + | 0 => g f + | S n' => 0 + end. diff --git a/test-suite/bugs/closed/1738.v b/test-suite/bugs/closed/1738.v new file mode 100644 index 00000000..c2926a2b --- /dev/null +++ b/test-suite/bugs/closed/1738.v @@ -0,0 +1,30 @@ +Require Import FSets. + +Module SomeSetoids (Import M:FSetInterface.S). + +Lemma Equal_refl : forall s, s[=]s. +Proof. red; split; auto. Qed. + +Add Relation t Equal + reflexivity proved by Equal_refl + symmetry proved by eq_sym + transitivity proved by eq_trans + as EqualSetoid. + +Add Morphism Empty with signature Equal ==> iff as Empty_m. +Proof. +unfold Equal, Empty; firstorder. +Qed. + +End SomeSetoids. + +Module Test (Import M:FSetInterface.S). + Module A:=SomeSetoids M. + Module B:=SomeSetoids M. (* lots of warning *) + + Lemma Test : forall s s', s[=]s' -> Empty s -> Empty s'. + intros. + rewrite H in H0. + assumption. +Qed. +End Test. \ No newline at end of file diff --git a/test-suite/bugs/closed/1740.v b/test-suite/bugs/closed/1740.v new file mode 100644 index 00000000..ec4a7a6b --- /dev/null +++ b/test-suite/bugs/closed/1740.v @@ -0,0 +1,23 @@ +(* Check that expansion of alias in pattern-matching compilation is no + longer dependent of whether the pattern-matching problem occurs in a + typed context or at toplevel (solved from revision 10883) *) + +Definition f := + fun n m : nat => + match n, m with + | O, _ => O + | n, O => n + | _, _ => O + end. + +Goal f = + fun n m : nat => + match n, m with + | O, _ => O + | n, O => n + | _, _ => O + end. + unfold f. + reflexivity. +Qed. + diff --git a/test-suite/bugs/closed/1754.v b/test-suite/bugs/closed/1754.v new file mode 100644 index 00000000..06b8dce8 --- /dev/null +++ b/test-suite/bugs/closed/1754.v @@ -0,0 +1,24 @@ +Axiom hp : Set. +Axiom cont : nat -> hp -> Prop. +Axiom sconj : (hp -> Prop) -> (hp -> Prop) -> hp -> Prop. +Axiom sconjImpl : forall h A B, + (sconj A B) h -> forall (A' B': hp -> Prop), + (forall h', A h' -> A' h') -> + (forall h', B h' -> B' h') -> + (sconj A' B') h. + +Definition cont' (h:hp) := exists y, cont y h. + +Lemma foo : forall h x y A, + (sconj (cont x) (sconj (cont y) A)) h -> + (sconj cont' (sconj cont' A)) h. +Proof. + intros h x y A H. + eapply sconjImpl. + 2:intros h' Hp'; econstructor; apply Hp'. + 2:intros h' Hp'; eapply sconjImpl. + 3:intros h'' Hp''; econstructor; apply Hp''. + 3:intros h'' Hp''; apply Hp''. + 2:apply Hp'. + clear H. +Admitted. diff --git a/test-suite/bugs/closed/1773.v b/test-suite/bugs/closed/1773.v new file mode 100644 index 00000000..211af89b --- /dev/null +++ b/test-suite/bugs/closed/1773.v @@ -0,0 +1,9 @@ +(* An occur-check test was done too early *) + +Goal forall B C : nat -> nat -> Prop, forall k, + (exists A, (forall k', C A k' -> B A k') -> B A k). +Proof. + intros B C k. + econstructor. + intros X. + apply X. (* used to fail here *) diff --git a/test-suite/bugs/closed/1774.v b/test-suite/bugs/closed/1774.v new file mode 100644 index 00000000..4c24b481 --- /dev/null +++ b/test-suite/bugs/closed/1774.v @@ -0,0 +1,18 @@ +Axiom pl : (nat -> Prop) -> (nat -> Prop) -> (nat -> Prop). +Axiom plImp : forall k P Q, + pl P Q k -> forall (P':nat -> Prop), + (forall k', P k' -> P' k') -> forall (Q':nat -> Prop), + (forall k', Q k' -> Q' k') -> + pl P' Q' k. + +Definition nexists (P:nat -> nat -> Prop) : nat -> Prop := + fun k' => exists k, P k k'. + +Goal forall k (A:nat -> nat -> Prop) (B:nat -> Prop), + pl (nexists A) B k. +intros. +eapply plImp. +2:intros m' M'; econstructor; apply M'. +2:intros m' M'; apply M'. +simpl. +Admitted. diff --git a/test-suite/bugs/closed/1775.v b/test-suite/bugs/closed/1775.v new file mode 100644 index 00000000..932949a3 --- /dev/null +++ b/test-suite/bugs/closed/1775.v @@ -0,0 +1,39 @@ +Axiom pair : nat -> nat -> nat -> Prop. +Axiom pl : (nat -> Prop) -> (nat -> Prop) -> (nat -> Prop). +Axiom plImp : forall k P Q, + pl P Q k -> forall (P':nat -> Prop), + (forall k', P k' -> P' k') -> forall (Q':nat -> Prop), + (forall k', Q k' -> Q' k') -> + pl P' Q' k. + +Definition nexists (P:nat -> nat -> Prop) : nat -> Prop := + fun k' => exists k, P k k'. + +Goal forall s k k' m, + (pl k' (nexists (fun w => (nexists (fun b => pl (pair w w) + (pl (pair s b) + (nexists (fun w0 => (nexists (fun a => pl (pair b w0) + (nexists (fun w1 => (nexists (fun c => pl + (pair a w1) (pl (pair a c) k))))))))))))))) m. +intros. +eapply plImp; [ | eauto | intros ]. +2:econstructor. +2:econstructor. +2:eapply plImp; [ | eauto | intros ]. +3:eapply plImp; [ | eauto | intros ]. +4:econstructor. +4:econstructor. +4:eapply plImp; [ | eauto | intros ]. +5:econstructor. +5:econstructor. +5:eauto. +4:eauto. +3:eauto. +2:eauto. + +assert (X := 1). +clear X. (* very slow! *) + +simpl. (* exception Not_found *) + +Admitted. diff --git a/test-suite/bugs/closed/1776.v b/test-suite/bugs/closed/1776.v new file mode 100644 index 00000000..58491f9d --- /dev/null +++ b/test-suite/bugs/closed/1776.v @@ -0,0 +1,22 @@ +Axiom pair : nat -> nat -> nat -> Prop. +Axiom pl : (nat -> Prop) -> (nat -> Prop) -> (nat -> Prop). +Axiom plImpR : forall k P Q, + pl P Q k -> forall (Q':nat -> Prop), + (forall k', Q k' -> Q' k') -> + pl P Q' k. + +Definition nexists (P:nat -> nat -> Prop) : nat -> Prop := + fun k' => exists k, P k k'. + +Goal forall a A m, + True -> + (pl A (nexists (fun x => (nexists + (fun y => pl (pair a (S x)) (pair a (S y))))))) m. +Proof. + intros. + eapply plImpR; [ | intros; econstructor; econstructor; eauto]. + clear H; + match goal with + | |- (pl _ (pl (pair _ ?x) _)) _ => replace x with 0 + end. +Admitted. diff --git a/test-suite/bugs/closed/1779.v b/test-suite/bugs/closed/1779.v new file mode 100644 index 00000000..95bb66b9 --- /dev/null +++ b/test-suite/bugs/closed/1779.v @@ -0,0 +1,25 @@ +Require Import Div2. + +Lemma double_div2: forall n, div2 (double n) = n. +exact (fun n => let _subcase := + let _cofact := fun _ : 0 = 0 => refl_equal 0 in + _cofact (let _fact := refl_equal 0 in _fact) in + let _subcase0 := + fun (m : nat) (Hrec : div2 (double m) = m) => + let _fact := f_equal div2 (double_S m) in + let _eq := trans_eq _fact (refl_equal (S (div2 (double m)))) in + let _eq0 := + trans_eq _eq + (trans_eq + (f_equal (fun f : nat -> nat => f (div2 (double m))) + (refl_equal S)) (f_equal S Hrec)) in + _eq0 in + (fix _fix (__ : nat) : div2 (double __) = __ := + match __ as n return (div2 (double n) = n) with + | 0 => _subcase + | S __0 => + (fun _hrec : div2 (double __0) = __0 => _subcase0 __0 _hrec) + (_fix __0) + end) n). +Guarded. +Defined. diff --git a/test-suite/bugs/closed/1784.v b/test-suite/bugs/closed/1784.v new file mode 100644 index 00000000..0b63d7b5 --- /dev/null +++ b/test-suite/bugs/closed/1784.v @@ -0,0 +1,101 @@ +Require Import List. +Require Import ZArith. +Require String. Open Scope string_scope. +Ltac Case s := let c := fresh "case" in set (c := s). + +Set Implicit Arguments. +Unset Strict Implicit. + +Inductive sv : Set := +| I : Z -> sv +| S : list sv -> sv. + +Section sv_induction. + +Variables + (VP: sv -> Prop) + (LP: list sv -> Prop) + + (VPint: forall n, VP (I n)) + (VPset: forall vs, LP vs -> VP (S vs)) + (lpcons: forall v vs, VP v -> LP vs -> LP (v::vs)) + (lpnil: LP nil). + +Fixpoint setl_value_indp (x:sv) {struct x}: VP x := + match x as x return VP x with + | I n => VPint n + | S vs => + VPset + ((fix values_indp (vs:list sv) {struct vs}: (LP vs) := + match vs as vs return LP vs with + | nil => lpnil + | v::vs => lpcons (setl_value_indp v) (values_indp vs) + end) vs) + end. +End sv_induction. + +Inductive slt : sv -> sv -> Prop := +| IC : forall z, slt (I z) (I z) +| IS : forall vs vs', slist_in vs vs' -> slt (S vs) (S vs') + +with sin : sv -> list sv -> Prop := +| Ihd : forall s s' sv', slt s s' -> sin s (s'::sv') +| Itl : forall s s' sv', sin s sv' -> sin s (s'::sv') + +with slist_in : list sv -> list sv -> Prop := +| Inil : forall sv', + slist_in nil sv' +| Icons : forall s sv sv', + sin s sv' -> + slist_in sv sv' -> + slist_in (s::sv) sv'. + +Hint Constructors sin slt slist_in. + +Require Import Program. + +Program Fixpoint lt_dec (x y:sv) { struct x } : {slt x y}+{~slt x y} := + match x with + | I x => + match y with + | I y => if (Z.eq_dec x y) then in_left else in_right + | S ys => in_right + end + | S xs => + match y with + | I y => in_right + | S ys => + let fix list_in (xs ys:list sv) {struct xs} : + {slist_in xs ys} + {~slist_in xs ys} := + match xs with + | nil => in_left + | x::xs => + let fix elem_in (ys:list sv) : {sin x ys}+{~sin x ys} := + match ys with + | nil => in_right + | y::ys => if lt_dec x y then in_left else if elem_in + ys then in_left else in_right + end + in + if elem_in ys then + if list_in xs ys then in_left else in_right + else in_right + end + in if list_in xs ys then in_left else in_right + end + end. + +Next Obligation. intro H0. apply H; inversion H0; subst; trivial. Defined. +Next Obligation. intro H; inversion H. Defined. +Next Obligation. intro H; inversion H. Defined. +Next Obligation. intro H; inversion H; subst. Defined. +Next Obligation. + intro H1; contradict H. inversion H1; subst. assumption. + contradict H0; assumption. Defined. +Next Obligation. + intro H1; contradict H0. inversion H1; subst. assumption. Defined. +Next Obligation. + intro H1; contradict H. inversion H1; subst. assumption. Defined. +Next Obligation. + intro H0; contradict H. inversion H0; subst; auto. Defined. + diff --git a/test-suite/bugs/closed/1791.v b/test-suite/bugs/closed/1791.v new file mode 100644 index 00000000..be0e8ae8 --- /dev/null +++ b/test-suite/bugs/closed/1791.v @@ -0,0 +1,38 @@ +(* simpl performs eta expansion *) + +Set Implicit Arguments. +Require Import List. + +Definition k0 := Set. +Definition k1 := k0 -> k0. + +(** iterating X n times *) +Fixpoint Pow (X:k1)(k:nat){struct k}:k1:= + match k with 0 => fun X => X + | S k' => fun A => X (Pow X k' A) + end. + +Parameter Bush: k1. +Parameter BushToList: forall (A:k0), Bush A -> list A. + +Definition BushnToList (n:nat)(A:k0)(t:Pow Bush n A): list A. +Proof. + intros. + induction n. + exact (t::nil). + simpl in t. + exact (flat_map IHn (BushToList t)). +Defined. + +Parameter bnil : forall (A:k0), Bush A. +Axiom BushToList_bnil: forall (A:k0), BushToList (bnil A) = nil(A:=A). + +Lemma BushnToList_bnil (n:nat)(A:k0): + BushnToList (S n) A (bnil (Pow Bush n A)) = nil. +Proof. + intros. + simpl. + rewrite BushToList_bnil. + simpl. + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/1834.v b/test-suite/bugs/closed/1834.v new file mode 100644 index 00000000..884ac01c --- /dev/null +++ b/test-suite/bugs/closed/1834.v @@ -0,0 +1,174 @@ +(* This tests rather deep nesting of abstracted terms *) + +(* This used to fail before Nov 2011 because of a de Bruijn indice bug + in extract_predicate. + + Note: use of eq_ok allows shorten notations but was not in the + original example +*) + +Scheme eq_rec_dep := Induction for eq Sort Type. + +Section Teq. + +Variable P0: Type. +Variable P1: forall (y0:P0), Type. +Variable P2: forall y0 (y1:P1 y0), Type. +Variable P3: forall y0 y1 (y2:P2 y0 y1), Type. +Variable P4: forall y0 y1 y2 (y3:P3 y0 y1 y2), Type. +Variable P5: forall y0 y1 y2 y3 (y4:P4 y0 y1 y2 y3), Type. + +Variable x0:P0. + +Inductive eq0 : P0 -> Prop := + refl0: eq0 x0. + +Definition eq_0 y0 := x0 = y0. + +Variable x1:P1 x0. + +Inductive eq1 : forall y0, P1 y0 -> Prop := + refl1: eq1 x0 x1. + +Definition S0_0 y0 (e0:eq_0 y0) := + eq_rec_dep P0 x0 (fun y0 e0 => P1 y0) x1 y0 e0. + +Definition eq_ok0 y0 y1 (E: eq_0 y0) := S0_0 y0 E = y1. + +Definition eq_1 y0 y1 := + {E0:eq_0 y0 | eq_ok0 y0 y1 E0}. + +Variable x2:P2 x0 x1. + +Inductive eq2 : +forall y0 y1, P2 y0 y1 -> Prop := +refl2: eq2 x0 x1 x2. + +Definition S1_0 y0 (e0:eq_0 y0) := +eq_rec_dep P0 x0 (fun y0 e0 => P2 y0 (S0_0 y0 e0)) x2 y0 e0. + +Definition S1_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := + eq_rec_dep (P1 y0) (S0_0 y0 e0) (fun y1 e1 => P2 y0 y1) + (S1_0 y0 e0) + y1 e1. + +Definition eq_ok1 y0 y1 y2 (E: eq_1 y0 y1) := + match E with exist _ e0 e1 => S1_1 y0 y1 e0 e1 = y2 end. + +Definition eq_2 y0 y1 y2 := + {E1:eq_1 y0 y1 | eq_ok1 y0 y1 y2 E1}. + +Variable x3:P3 x0 x1 x2. + +Inductive eq3 : +forall y0 y1 y2, P3 y0 y1 y2 -> Prop := +refl3: eq3 x0 x1 x2 x3. + +Definition S2_0 y0 (e0:eq_0 y0) := +eq_rec_dep P0 x0 (fun y0 e0 => P3 y0 (S0_0 y0 e0) (S1_0 y0 e0)) x3 y0 e0. + +Definition S2_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := + eq_rec_dep (P1 y0) (S0_0 y0 e0) + (fun y1 e1 => P3 y0 y1 (S1_1 y0 y1 e0 e1)) + (S2_0 y0 e0) + y1 e1. + +Definition S2_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) + (e2:S1_1 y0 y1 e0 e1 = y2) := + eq_rec_dep (P2 y0 y1) (S1_1 y0 y1 e0 e1) + (fun y2 e2 => P3 y0 y1 y2) + (S2_1 y0 y1 e0 e1) + y2 e2. + +Definition eq_ok2 y0 y1 y2 y3 (E: eq_2 y0 y1 y2) : Prop := + match E with exist _ (exist _ e0 e1) e2 => + S2_2 y0 y1 y2 e0 e1 e2 = y3 end. + +Definition eq_3 y0 y1 y2 y3 := + {E2: eq_2 y0 y1 y2 | eq_ok2 y0 y1 y2 y3 E2}. + +Variable x4:P4 x0 x1 x2 x3. + +Inductive eq4 : +forall y0 y1 y2 y3, P4 y0 y1 y2 y3 -> Prop := +refl4: eq4 x0 x1 x2 x3 x4. + +Definition S3_0 y0 (e0:eq_0 y0) := +eq_rec_dep P0 x0 (fun y0 e0 => P4 y0 (S0_0 y0 e0) (S1_0 y0 e0) (S2_0 y0 e0)) + x4 y0 e0. + +Definition S3_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := + eq_rec_dep (P1 y0) (S0_0 y0 e0) + (fun y1 e1 => P4 y0 y1 (S1_1 y0 y1 e0 e1) (S2_1 y0 y1 e0 e1)) + (S3_0 y0 e0) + y1 e1. + +Definition S3_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) + (e2:S1_1 y0 y1 e0 e1 = y2) := + eq_rec_dep (P2 y0 y1) (S1_1 y0 y1 e0 e1) + (fun y2 e2 => P4 y0 y1 y2 (S2_2 y0 y1 y2 e0 e1 e2)) + (S3_1 y0 y1 e0 e1) + y2 e2. + +Definition S3_3 y0 y1 y2 y3 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) + (e2:S1_1 y0 y1 e0 e1 = y2) (e3:S2_2 y0 y1 y2 e0 e1 e2 = y3):= + eq_rec_dep (P3 y0 y1 y2) (S2_2 y0 y1 y2 e0 e1 e2) + (fun y3 e3 => P4 y0 y1 y2 y3) + (S3_2 y0 y1 y2 e0 e1 e2) + y3 e3. + +Definition eq_ok3 y0 y1 y2 y3 y4 (E: eq_3 y0 y1 y2 y3) : Prop := + match E with exist _ (exist _ (exist _ e0 e1) e2) e3 => + S3_3 y0 y1 y2 y3 e0 e1 e2 e3 = y4 end. + +Definition eq_4 y0 y1 y2 y3 y4 := + {E3: eq_3 y0 y1 y2 y3 | eq_ok3 y0 y1 y2 y3 y4 E3}. + +Variable x5:P5 x0 x1 x2 x3 x4. + +Inductive eq5 : +forall y0 y1 y2 y3 y4, P5 y0 y1 y2 y3 y4 -> Prop := +refl5: eq5 x0 x1 x2 x3 x4 x5. + +Definition S4_0 y0 (e0:eq_0 y0) := +eq_rec_dep P0 x0 +(fun y0 e0 => P5 y0 (S0_0 y0 e0) (S1_0 y0 e0) (S2_0 y0 e0) (S3_0 y0 e0)) + x5 y0 e0. + +Definition S4_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := + eq_rec_dep (P1 y0) (S0_0 y0 e0) + (fun y1 e1 => P5 y0 y1 (S1_1 y0 y1 e0 e1) (S2_1 y0 y1 e0 e1) (S3_1 y0 y1 e0 +e1)) + (S4_0 y0 e0) + y1 e1. + +Definition S4_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) + (e2:S1_1 y0 y1 e0 e1 = y2) := + eq_rec_dep (P2 y0 y1) (S1_1 y0 y1 e0 e1) + (fun y2 e2 => P5 y0 y1 y2 (S2_2 y0 y1 y2 e0 e1 e2) (S3_2 y0 y1 y2 e0 e1 e2)) + (S4_1 y0 y1 e0 e1) + y2 e2. + +Definition S4_3 y0 y1 y2 y3 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) + (e2:S1_1 y0 y1 e0 e1 = y2) (e3:S2_2 y0 y1 y2 e0 e1 e2 = y3):= + eq_rec_dep (P3 y0 y1 y2) (S2_2 y0 y1 y2 e0 e1 e2) + (fun y3 e3 => P5 y0 y1 y2 y3 (S3_3 y0 y1 y2 y3 e0 e1 e2 e3)) + (S4_2 y0 y1 y2 e0 e1 e2) + y3 e3. + +Definition S4_4 y0 y1 y2 y3 y4 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) + (e2:S1_1 y0 y1 e0 e1 = y2) (e3:S2_2 y0 y1 y2 e0 e1 e2 = y3) + (e4:S3_3 y0 y1 y2 y3 e0 e1 e2 e3 = y4) := + eq_rec_dep (P4 y0 y1 y2 y3) (S3_3 y0 y1 y2 y3 e0 e1 e2 e3) + (fun y4 e4 => P5 y0 y1 y2 y3 y4) + (S4_3 y0 y1 y2 y3 e0 e1 e2 e3) + y4 e4. + +Definition eq_ok4 y0 y1 y2 y3 y4 y5 (E: eq_4 y0 y1 y2 y3 y4) : Prop := + match E with exist _ (exist _ (exist _ (exist _ e0 e1) e2) e3) e4 => + S4_4 y0 y1 y2 y3 y4 e0 e1 e2 e3 e4 = y5 end. + +Definition eq_5 y0 y1 y2 y3 y4 y5 := + {E4: eq_4 y0 y1 y2 y3 y4 | eq_ok4 y0 y1 y2 y3 y4 y5 E4 }. + +End Teq. diff --git a/test-suite/bugs/closed/1844.v b/test-suite/bugs/closed/1844.v new file mode 100644 index 00000000..17eeb352 --- /dev/null +++ b/test-suite/bugs/closed/1844.v @@ -0,0 +1,217 @@ +Require Import ZArith. + +Definition zeq := Z.eq_dec. + +Definition update (A: Set) (x: Z) (v: A) (s: Z -> A) : Z -> A := + fun y => if zeq x y then v else s y. + +Implicit Arguments update [A]. + +Definition ident := Z. +Parameter operator: Set. +Parameter value: Set. +Parameter is_true: value -> Prop. +Definition label := Z. + +Inductive expr : Set := + | Evar: ident -> expr + | Econst: value -> expr + | Eop: operator -> expr -> expr -> expr. + +Inductive stmt : Set := + | Sskip: stmt + | Sassign: ident -> expr -> stmt + | Scall: ident -> ident -> expr -> stmt (* x := f(e) *) + | Sreturn: expr -> stmt + | Sseq: stmt -> stmt -> stmt + | Sifthenelse: expr -> stmt -> stmt -> stmt + | Sloop: stmt -> stmt + | Sblock: stmt -> stmt + | Sexit: nat -> stmt + | Slabel: label -> stmt -> stmt + | Sgoto: label -> stmt. + +Record function : Set := mkfunction { + fn_param: ident; + fn_body: stmt +}. + +Parameter program: ident -> option function. + +Parameter main_function: ident. + +Definition store := ident -> value. + +Parameter empty_store : store. + +Parameter eval_op: operator -> value -> value -> option value. + +Fixpoint eval_expr (st: store) (e: expr) {struct e} : option value := + match e with + | Evar v => Some (st v) + | Econst v => Some v + | Eop op e1 e2 => + match eval_expr st e1, eval_expr st e2 with + | Some v1, Some v2 => eval_op op v1 v2 + | _, _ => None + end + end. + +Inductive outcome: Set := + | Onormal: outcome + | Oexit: nat -> outcome + | Ogoto: label -> outcome + | Oreturn: value -> outcome. + +Definition outcome_block (out: outcome) : outcome := + match out with + | Onormal => Onormal + | Oexit O => Onormal + | Oexit (S m) => Oexit m + | Ogoto lbl => Ogoto lbl + | Oreturn v => Oreturn v + end. + +Fixpoint label_defined (lbl: label) (s: stmt) {struct s}: Prop := + match s with + | Sskip => False + | Sassign id e => False + | Scall id fn e => False + | Sreturn e => False + | Sseq s1 s2 => label_defined lbl s1 \/ label_defined lbl s2 + | Sifthenelse e s1 s2 => label_defined lbl s1 \/ label_defined lbl s2 + | Sloop s1 => label_defined lbl s1 + | Sblock s1 => label_defined lbl s1 + | Sexit n => False + | Slabel lbl1 s1 => lbl1 = lbl \/ label_defined lbl s1 + | Sgoto lbl => False + end. + +Inductive exec : stmt -> store -> outcome -> store -> Prop := + | exec_skip: forall st, + exec Sskip st Onormal st + | exec_assign: forall id e st v, + eval_expr st e = Some v -> + exec (Sassign id e) st Onormal (update id v st) + | exec_call: forall id fn e st v1 f v2 st', + eval_expr st e = Some v1 -> + program fn = Some f -> + exec_function f (update f.(fn_param) v1 empty_store) v2 st' -> + exec (Scall id fn e) st Onormal (update id v2 st) + | exec_return: forall e st v, + eval_expr st e = Some v -> + exec (Sreturn e) st (Oreturn v) st + | exec_seq_2: forall s1 s2 st st1 out' st', + exec s1 st Onormal st1 -> exec s2 st1 out' st' -> + exec (Sseq s1 s2) st out' st' + | exec_seq_1: forall s1 s2 st out st', + exec s1 st out st' -> out <> Onormal -> + exec (Sseq s1 s2) st out st' + | exec_ifthenelse_true: forall e s1 s2 st out st' v, + eval_expr st e = Some v -> is_true v -> exec s1 st out st' -> + exec (Sifthenelse e s1 s2) st out st' + | exec_ifthenelse_false: forall e s1 s2 st out st' v, + eval_expr st e = Some v -> ~is_true v -> exec s2 st out st' -> + exec (Sifthenelse e s1 s2) st out st' + | exec_loop_loop: forall s st st1 out' st', + exec s st Onormal st1 -> + exec (Sloop s) st1 out' st' -> + exec (Sloop s) st out' st' + | exec_loop_stop: forall s st st' out, + exec s st out st' -> out <> Onormal -> + exec (Sloop s) st out st' + | exec_block: forall s st out st', + exec s st out st' -> + exec (Sblock s) st (outcome_block out) st' + | exec_exit: forall n st, + exec (Sexit n) st (Oexit n) st + | exec_label: forall s lbl st st' out, + exec s st out st' -> + exec (Slabel lbl s) st out st' + | exec_goto: forall st lbl, + exec (Sgoto lbl) st (Ogoto lbl) st + +(** [execg lbl stmt st out st'] starts executing at label [lbl] within [s], + in initial store [st]. The result of the execution is the outcome + [out] with final store [st']. *) + +with execg: label -> stmt -> store -> outcome -> store -> Prop := + | execg_left_seq_2: forall lbl s1 s2 st st1 out' st', + execg lbl s1 st Onormal st1 -> exec s2 st1 out' st' -> + execg lbl (Sseq s1 s2) st out' st' + | execg_left_seq_1: forall lbl s1 s2 st out st', + execg lbl s1 st out st' -> out <> Onormal -> + execg lbl (Sseq s1 s2) st out st' + | execg_right_seq: forall lbl s1 s2 st out st', + ~(label_defined lbl s1) -> + execg lbl s2 st out st' -> + execg lbl (Sseq s1 s2) st out st' + | execg_ifthenelse_left: forall lbl e s1 s2 st out st', + execg lbl s1 st out st' -> + execg lbl (Sifthenelse e s1 s2) st out st' + | execg_ifthenelse_right: forall lbl e s1 s2 st out st', + ~(label_defined lbl s1) -> + execg lbl s2 st out st' -> + execg lbl (Sifthenelse e s1 s2) st out st' + | execg_loop_loop: forall lbl s st st1 out' st', + execg lbl s st Onormal st1 -> + exec (Sloop s) st1 out' st' -> + execg lbl (Sloop s) st out' st' + | execg_loop_stop: forall lbl s st st' out, + execg lbl s st out st' -> out <> Onormal -> + execg lbl (Sloop s) st out st' + | execg_block: forall lbl s st out st', + execg lbl s st out st' -> + execg lbl (Sblock s) st (outcome_block out) st' + | execg_label_found: forall lbl s st st' out, + exec s st out st' -> + execg lbl (Slabel lbl s) st out st' + | execg_label_notfound: forall lbl s lbl' st st' out, + lbl' <> lbl -> + execg lbl s st out st' -> + execg lbl (Slabel lbl' s) st out st' + +(** [exec_finish out st st'] takes the outcome [out] and the store [st] + at the end of the evaluation of the program. If [out] is a [goto], + execute again the program starting at the corresponding label. + Iterate this way until [out] is [Onormal]. *) + +with exec_finish: function -> outcome -> store -> value -> store -> Prop := + | exec_finish_normal: forall f st v, + exec_finish f (Oreturn v) st v st + | exec_finish_goto: forall f lbl st out v st1 st', + execg lbl f.(fn_body) st out st1 -> + exec_finish f out st1 v st' -> + exec_finish f (Ogoto lbl) st v st' + +(** Execution of a function *) + +with exec_function: function -> store -> value -> store -> Prop := + | exec_function_intro: forall f st out st1 v st', + exec f.(fn_body) st out st1 -> + exec_finish f out st1 v st' -> + exec_function f st v st'. + +Scheme exec_ind4:= Minimality for exec Sort Prop + with execg_ind4:= Minimality for execg Sort Prop + with exec_finish_ind4 := Minimality for exec_finish Sort Prop + with exec_function_ind4 := Minimality for exec_function Sort Prop. + +Scheme exec_dind4:= Induction for exec Sort Prop + with execg_dind4:= Minimality for execg Sort Prop + with exec_finish_dind4 := Induction for exec_finish Sort Prop + with exec_function_dind4 := Induction for exec_function Sort Prop. + +Combined Scheme exec_inductiond from exec_dind4, execg_dind4, exec_finish_dind4, + exec_function_dind4. + +Scheme exec_dind4' := Induction for exec Sort Prop + with execg_dind4' := Induction for execg Sort Prop + with exec_finish_dind4' := Induction for exec_finish Sort Prop + with exec_function_dind4' := Induction for exec_function Sort Prop. + +Combined Scheme exec_induction from exec_ind4, execg_ind4, exec_finish_ind4, + exec_function_ind4. + +Combined Scheme exec_inductiond' from exec_dind4', execg_dind4', exec_finish_dind4', + exec_function_dind4'. diff --git a/test-suite/bugs/closed/1865.v b/test-suite/bugs/closed/1865.v new file mode 100644 index 00000000..17c19989 --- /dev/null +++ b/test-suite/bugs/closed/1865.v @@ -0,0 +1,18 @@ +(* Check that tactics (here dependent inversion) do not generate + conversion problems T <= U with sup's of universes in U *) + +(* Submitted by David Nowak *) + +Inductive list (A:Set) : nat -> Set := +| nil : list A O +| cons : forall n, A -> list A n -> list A (S n). + +Definition f (n:nat) : Type := + match n with + | O => bool + | _ => unit + end. + +Goal forall A n, list A n -> f n. +intros A n. +dependent inversion n. diff --git a/test-suite/bugs/closed/1891.v b/test-suite/bugs/closed/1891.v new file mode 100644 index 00000000..68581117 --- /dev/null +++ b/test-suite/bugs/closed/1891.v @@ -0,0 +1,13 @@ +(* Check evar-evar unification *) + Inductive T (A: Set): Set := mkT: unit -> T A. + + Definition f (A: Set) (l: T A): unit := tt. + + Implicit Arguments f [A]. + + Lemma L (x: T unit): (unit -> T unit) -> unit. + Proof. + refine (match x return _ with mkT _ n => fun g => f (g _) end). + trivial. + Qed. + diff --git a/test-suite/bugs/closed/1898.v b/test-suite/bugs/closed/1898.v new file mode 100644 index 00000000..70461286 --- /dev/null +++ b/test-suite/bugs/closed/1898.v @@ -0,0 +1,6 @@ +(* folding should not allow circular dependencies *) + +Lemma bug_fold_unfold : True. + set (h := 1). + Fail fold h in h. + Abort. diff --git a/test-suite/bugs/closed/1900.v b/test-suite/bugs/closed/1900.v new file mode 100644 index 00000000..cf03efda --- /dev/null +++ b/test-suite/bugs/closed/1900.v @@ -0,0 +1,8 @@ +Parameter A : Type . + +Definition eq_A := @eq A. + +Goal forall x, eq_A x x. +intros. +reflexivity. +Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/1901.v b/test-suite/bugs/closed/1901.v new file mode 100644 index 00000000..7d86adbf --- /dev/null +++ b/test-suite/bugs/closed/1901.v @@ -0,0 +1,11 @@ +Require Import Relations. + +Record Poset{A:Type}(Le : relation A) : Type := + Build_Poset + { + Le_refl : forall x : A, Le x x; + Le_trans : forall x y z : A, Le x y -> Le y z -> Le x z; + Le_antisym : forall x y : A, Le x y -> Le y x -> x = y }. + +Definition nat_Poset : Poset Peano.le. +Admitted. \ No newline at end of file diff --git a/test-suite/bugs/closed/1905.v b/test-suite/bugs/closed/1905.v new file mode 100644 index 00000000..8c81d751 --- /dev/null +++ b/test-suite/bugs/closed/1905.v @@ -0,0 +1,13 @@ + +Require Import Setoid Program. + +Axiom t : Set. +Axiom In : nat -> t -> Prop. +Axiom InE : forall (x : nat) (s:t), impl (In x s) True. + +Goal forall a s, + In a s -> False. +Proof. + intros a s Ia. + rewrite InE in Ia. +Admitted. \ No newline at end of file diff --git a/test-suite/bugs/closed/1907.v b/test-suite/bugs/closed/1907.v new file mode 100644 index 00000000..55fc8231 --- /dev/null +++ b/test-suite/bugs/closed/1907.v @@ -0,0 +1,7 @@ +(* An example of type inference *) + +Axiom A : Type. +Definition f (x y : A) := x. +Axiom g : forall x y : A, f x y = y -> Prop. +Axiom x : A. +Check (g x _ (refl_equal x)). diff --git a/test-suite/bugs/closed/1912.v b/test-suite/bugs/closed/1912.v new file mode 100644 index 00000000..987a5417 --- /dev/null +++ b/test-suite/bugs/closed/1912.v @@ -0,0 +1,6 @@ +Require Import ZArith. + +Goal forall x, Z.succ (Z.pred x) = x. +intros x. +omega. +Qed. diff --git a/test-suite/bugs/closed/1915.v b/test-suite/bugs/closed/1915.v new file mode 100644 index 00000000..7e62437d --- /dev/null +++ b/test-suite/bugs/closed/1915.v @@ -0,0 +1,6 @@ + +Require Import Setoid. + +Fail Goal forall x, impl True (x = 0) -> x = 0 -> False. +(*intros x H E. +rewrite H in E.*) \ No newline at end of file diff --git a/test-suite/bugs/closed/1918.v b/test-suite/bugs/closed/1918.v new file mode 100644 index 00000000..9d92fe12 --- /dev/null +++ b/test-suite/bugs/closed/1918.v @@ -0,0 +1,376 @@ +(** Occur-check for Meta (up to delta) *) + +(** LNMItPredShort.v Version 2.0 July 2008 *) +(** does not need impredicative Set, runs under V8.2, tested with SVN 11296 *) + +(** Copyright Ralph Matthes, I.R.I.T., C.N.R.S. & University of Toulouse*) + + +Set Implicit Arguments. + +(** the universe of all monotypes *) +Definition k0 := Set. + +(** the type of all type transformations *) +Definition k1 := k0 -> k0. + +(** the type of all rank-2 type transformations *) +Definition k2 := k1 -> k1. + +(** polymorphic identity *) +Definition id : forall (A:Set), A -> A := fun A x => x. + +(** composition *) +Definition comp (A B C:Set)(g:B->C)(f:A->B) : A->C := fun x => g (f x). + +Infix "o" := comp (at level 90). + +Definition sub_k1 (X Y:k1) : Type := + forall A:Set, X A -> Y A. + +Infix "c_k1" := sub_k1 (at level 60). + +(** monotonicity *) +Definition mon (X:k1) : Type := forall (A B:Set), (A -> B) -> X A -> X B. + +(** extensionality *) +Definition ext (X:k1)(h: mon X): Prop := + forall (A B:Set)(f g:A -> B), + (forall a, f a = g a) -> forall r, h _ _ f r = h _ _ g r. + +(** first functor law *) +Definition fct1 (X:k1)(m: mon X) : Prop := + forall (A:Set)(x:X A), m _ _ (id(A:=A)) x = x. + +(** second functor law *) +Definition fct2 (X:k1)(m: mon X) : Prop := + forall (A B C:Set)(f:A -> B)(g:B -> C)(x:X A), + m _ _ (g o f) x = m _ _ g (m _ _ f x). + +(** pack up the good properties of the approximation into + the notion of an extensional functor *) +Record EFct (X:k1) : Type := mkEFct + { m : mon X; + e : ext m; + f1 : fct1 m; + f2 : fct2 m }. + +(** preservation of extensional functors *) +Definition pEFct (F:k2) : Type := + forall (X:k1), EFct X -> EFct (F X). + + +(** we show some closure properties of pEFct, depending on such properties + for EFct *) + +Definition moncomp (X Y:k1)(mX:mon X)(mY:mon Y): mon (fun A => X(Y A)). +Proof. + red. + intros A B f x. + exact (mX (Y A)(Y B) (mY A B f) x). +Defined. + +(** closure under composition *) +Lemma compEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X(Y A)). +Proof. + intros ef1 ef2. + apply (mkEFct(m:=moncomp (m ef1) (m ef2))); red; intros; unfold moncomp. +(* prove ext *) + apply (e ef1). + intro. + apply (e ef2); trivial. +(* prove fct1 *) + rewrite (e ef1 (m ef2 (id (A:=A))) (id(A:=Y A))). + apply (f1 ef1). + intro. + apply (f1 ef2). +(* prove fct2 *) + rewrite (e ef1 (m ef2 (g o f))((m ef2 g)o(m ef2 f))). + apply (f2 ef1). + intro. + unfold comp at 2. + apply (f2 ef2). +Defined. + +Corollary comppEFct (F G:k2): pEFct F -> pEFct G -> + pEFct (fun X A => F X (G X A)). +Proof. + red. + intros. + apply compEFct; auto. +Defined. + +(** closure under sums *) +Lemma sumEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X A + Y A)%type. +Proof. + intros ef1 ef2. + set (m12:=fun (A B:Set)(f:A->B) x => match x with + | inl y => inl _ (m ef1 f y) + | inr y => inr _ (m ef2 f y) + end). + apply (mkEFct(m:=m12)); red; intros. +(* prove ext *) + destruct r. + simpl. + apply (f_equal (fun x=>inl (A:=X B) (Y B) x)). + apply (e ef1); trivial. + simpl. + apply (f_equal (fun x=>inr (X B) (B:=Y B) x)). + apply (e ef2); trivial. +(* prove fct1 *) + destruct x. + simpl. + apply (f_equal (fun x=>inl (A:=X A) (Y A) x)). + apply (f1 ef1). + simpl. + apply (f_equal (fun x=>inr (X A) (B:=Y A) x)). + apply (f1 ef2). +(* prove fct2 *) + destruct x. + simpl. + rewrite (f2 ef1); reflexivity. + simpl. + rewrite (f2 ef2); reflexivity. +Defined. + +Corollary sumpEFct (F G:k2): pEFct F -> pEFct G -> + pEFct (fun X A => F X A + G X A)%type. +Proof. + red. + intros. + apply sumEFct; auto. +Defined. + +(** closure under products *) +Lemma prodEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X A * Y A)%type. +Proof. + intros ef1 ef2. + set (m12:=fun (A B:Set)(f:A->B) x => match x with + (x1,x2) => (m ef1 f x1, m ef2 f x2) end). + apply (mkEFct(m:=m12)); red; intros. +(* prove ext *) + destruct r as [x1 x2]. + simpl. + apply injective_projections; simpl. + apply (e ef1); trivial. + apply (e ef2); trivial. +(* prove fct1 *) + destruct x as [x1 x2]. + simpl. + apply injective_projections; simpl. + apply (f1 ef1). + apply (f1 ef2). +(* prove fct2 *) + destruct x as [x1 x2]. + simpl. + apply injective_projections; simpl. + apply (f2 ef1). + apply (f2 ef2). +Defined. + +Corollary prodpEFct (F G:k2): pEFct F -> pEFct G -> + pEFct (fun X A => F X A * G X A)%type. +Proof. + red. + intros. + apply prodEFct; auto. +Defined. + +(** the identity in k2 preserves extensional functors *) +Lemma idpEFct: pEFct (fun X => X). +Proof. + red. + intros. + assumption. +Defined. + +(** a variant for the eta-expanded identity *) +Lemma idpEFct_eta: pEFct (fun X A => X A). +Proof. + red. + intros X ef. + destruct ef as [m0 e0 f01 f02]. + change (mon X) with (mon (fun A => X A)) in m0. + apply (mkEFct (m:=m0) e0 f01 f02). +Defined. + +(** the identity in k1 "is" an extensional functor *) +Lemma idEFct: EFct (fun A => A). +Proof. + set (mId:=fun A B (f:A->B)(x:A) => f x). + apply (mkEFct(m:=mId)). + red. + intros. + unfold mId. + apply H. + red. + reflexivity. + red. + reflexivity. +Defined. + +(** constants in k2 *) +Lemma constpEFct (X:k1): EFct X -> pEFct (fun _ => X). +Proof. + red. + intros. + assumption. +Defined. + +(** constants in k1 *) +Lemma constEFct (C:Set): EFct (fun _ => C). +Proof. + set (mC:=fun A B (f:A->B)(x:C) => x). + apply (mkEFct(m:=mC)); red; intros; unfold mC; reflexivity. +Defined. + + +(** the option type *) +Lemma optionEFct: EFct (fun (A:Set) => option A). + apply (mkEFct (X:=fun (A:Set) => option A)(m:=option_map)); red; intros. + destruct r. + simpl. + rewrite H. + reflexivity. + reflexivity. + destruct x; reflexivity. + destruct x; reflexivity. +Defined. + + +(** natural transformations from (X,mX) to (Y,mY) *) +Definition NAT(X Y:k1)(j:X c_k1 Y)(mX:mon X)(mY:mon Y) : Prop := + forall (A B:Set)(f:A->B)(t:X A), j B (mX A B f t) = mY _ _ f (j A t). + + +Module Type LNMIt_Type. + +Parameter F:k2. +Parameter FpEFct: pEFct F. +Parameter mu20: k1. +Definition mu2: k1:= fun A => mu20 A. +Parameter mapmu2: mon mu2. +Definition MItType: Type := + forall G : k1, (forall X : k1, X c_k1 G -> F X c_k1 G) -> mu2 c_k1 G. +Parameter MIt0 : MItType. +Definition MIt : MItType:= fun G s A t => MIt0 s t. +Definition InType : Type := + forall (X:k1)(ef:EFct X)(j: X c_k1 mu2), + NAT j (m ef) mapmu2 -> F X c_k1 mu2. +Parameter In : InType. +Axiom mapmu2Red : forall (A:Set)(X:k1)(ef:EFct X)(j: X c_k1 mu2) + (n: NAT j (m ef) mapmu2)(t: F X A)(B:Set)(f:A->B), + mapmu2 f (In ef n t) = In ef n (m (FpEFct ef) f t). +Axiom MItRed : forall (G : k1) + (s : forall X : k1, X c_k1 G -> F X c_k1 G)(X : k1)(ef:EFct X)(j: X c_k1 mu2) + (n: NAT j (m ef) mapmu2)(A:Set)(t:F X A), + MIt s (In ef n t) = s X (fun A => (MIt s (A:=A)) o (j A)) A t. +Definition mu2IndType : Prop := + forall (P : (forall A : Set, mu2 A -> Prop)), + (forall (X : k1)(ef:EFct X)(j : X c_k1 mu2)(n: NAT j (m ef) mapmu2), + (forall (A : Set) (x : X A), P A (j A x)) -> + forall (A:Set)(t : F X A), P A (In ef n t)) -> + forall (A : Set) (r : mu2 A), P A r. +Axiom mu2Ind : mu2IndType. + +End LNMIt_Type. + +(** BushDepPredShort.v Version 0.2 July 2008 *) +(** does not need impredicative Set, produces stack overflow under V8.2, tested +with SVN 11296 *) + +(** Copyright Ralph Matthes, I.R.I.T., C.N.R.S. & University of Toulouse *) + +Set Implicit Arguments. + +Require Import List. + +Definition listk1 (A:Set) : Set := list A. +Open Scope type_scope. + +Definition BushF(X:k1)(A:Set) := unit + A * X (X A). + +Definition bushpEFct : pEFct BushF. +Proof. + unfold BushF. + apply sumpEFct. + apply constpEFct. + apply constEFct. + apply prodpEFct. + apply constpEFct. + apply idEFct. + apply comppEFct. + apply idpEFct. + apply idpEFct_eta. +Defined. + +Module Type BUSH := LNMIt_Type with Definition F:=BushF + with Definition FpEFct := +bushpEFct. + +Module Bush (BushBase:BUSH). + +Definition Bush : k1 := BushBase.mu2. + +Definition bush : mon Bush := BushBase.mapmu2. + +End Bush. + + +Definition Id : k1 := fun X => X. + +Fixpoint Pow (X:k1)(k:nat){struct k}:k1:= + match k with 0 => Id + | S k' => fun A => X (Pow X k' A) + end. + +Fixpoint POW (k:nat)(X:k1)(m:mon X){struct k} : mon (Pow X k) := + match k return mon (Pow X k) + with 0 => fun _ _ f => f + | S k' => fun _ _ f => m _ _ (POW k' m f) + end. + +Module Type BushkToList_Type. + +Declare Module Import BP: BUSH. +Definition F:=BushF. +Definition FpEFct:= bushpEFct. +Definition mu20 := mu20. +Definition mu2 := mu2. +Definition mapmu2 := mapmu2. +Definition MItType:= MItType. +Definition MIt0 := MIt0. +Definition MIt := MIt. +Definition InType := InType. +Definition In := In. +Definition mapmu2Red:=mapmu2Red. +Definition MItRed:=MItRed. +Definition mu2IndType:=mu2IndType. +Definition mu2Ind:=mu2Ind. + +Definition Bush:= mu2. +Module BushM := Bush BP. + +Parameter BushkToList: forall(k:nat)(A:k0)(t:Pow Bush k A), list A. +Axiom BushkToList0: forall(A:k0)(t:Pow Bush 0 A), BushkToList 0 A t = t::nil. + +End BushkToList_Type. + +Module BushDep (BushkToListM:BushkToList_Type). + +Module Bush := Bush BushkToListM. + +Import Bush. +Import BushkToListM. + + +Lemma BushkToList0NAT: NAT(Y:=listk1) (BushkToList 0) (POW 0 bush) map. +Proof. + red. + intros. + simpl. + rewrite BushkToList0. +(* stack overflow for coqc and coqtop *) + + +Abort. diff --git a/test-suite/bugs/closed/1925.v b/test-suite/bugs/closed/1925.v new file mode 100644 index 00000000..4caee1c3 --- /dev/null +++ b/test-suite/bugs/closed/1925.v @@ -0,0 +1,22 @@ +(* Check that the analysis of projectable rel's in an evar instance is up to + aliases *) + +Require Import List. + +Definition compose (A B C : Type) (g : B -> C) (f : A -> B) : A -> C := + fun x : A => g(f x). + +Definition map_fuse' : + forall (A B C : Type) (g : B -> C) (f : A -> B) (xs : list A), + (map g (map f xs)) = map (compose _ _ _ g f) xs + := + fun A B C g f => + (fix loop (ys : list A) {struct ys} := + match ys as ys return (map g (map f ys)) = map (compose _ _ _ g f) ys + with + | nil => refl_equal nil + | x :: xs => + match loop xs in eq _ a return eq _ ((g (f x)) :: a) with + | refl_equal => refl_equal (map g (map f (x :: xs))) + end + end). diff --git a/test-suite/bugs/closed/1931.v b/test-suite/bugs/closed/1931.v new file mode 100644 index 00000000..930ace1d --- /dev/null +++ b/test-suite/bugs/closed/1931.v @@ -0,0 +1,29 @@ + + +Set Implicit Arguments. + +Inductive T (A:Set) : Set := + app : T A -> T A -> T A. + +Fixpoint map (A B:Set)(f:A->B)(t:T A) : T B := + match t with + app t1 t2 => app (map f t1)(map f t2) + end. + +Fixpoint subst (A B:Set)(f:A -> T B)(t:T A) :T B := + match t with + app t1 t2 => app (subst f t1)(subst f t2) + end. + +(* This is the culprit: *) +Definition k0:=Set. + +(** interaction of subst with map *) +Lemma substLaw1 (A:k0)(B C:Set)(f: A -> B)(g:B -> T C)(t: T A): + subst g (map f t) = subst (fun x => g (f x)) t. +Proof. + intros. + generalize B C f g; clear B C f g. + induction t; intros; simpl. + f_equal. +Admitted. diff --git a/test-suite/bugs/closed/1935.v b/test-suite/bugs/closed/1935.v new file mode 100644 index 00000000..d5837619 --- /dev/null +++ b/test-suite/bugs/closed/1935.v @@ -0,0 +1,21 @@ +Definition f (n:nat) := n = n. + +Lemma f_refl : forall n , f n. +intros. reflexivity. +Qed. + +Definition f' (x:nat) (n:nat) := n = n. + +Lemma f_refl' : forall n , f' n n. +Proof. + intros. reflexivity. +Qed. + +Require Import ZArith. + +Definition f'' (a:bool) := if a then eq (A:= Z) else Z.lt. + +Lemma f_refl'' : forall n , f'' true n n. +Proof. + intro. reflexivity. +Qed. diff --git a/test-suite/bugs/closed/1939.v b/test-suite/bugs/closed/1939.v new file mode 100644 index 00000000..5e61529b --- /dev/null +++ b/test-suite/bugs/closed/1939.v @@ -0,0 +1,19 @@ +Require Import Setoid Program.Basics. + + Parameter P : nat -> Prop. + Parameter R : nat -> nat -> Prop. + + Add Parametric Morphism : P + with signature R ++> impl as PM1. + Admitted. + + Add Parametric Morphism : P + with signature R --> impl as PM2. + Admitted. + + Goal forall x y, R x y -> P y -> P x. + Proof. + intros x y H1 H2. + rewrite H1. + auto. + Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/1944.v b/test-suite/bugs/closed/1944.v new file mode 100644 index 00000000..ee2918c6 --- /dev/null +++ b/test-suite/bugs/closed/1944.v @@ -0,0 +1,9 @@ +(* Test some uses of ? in introduction patterns *) + +Inductive J : nat -> Prop := + | K : forall p, J p -> (True /\ True) -> J (S p). + +Lemma bug : forall n, J n -> J (S n). +Proof. + intros ? H. + induction H as [? ? [? ?]]. diff --git a/test-suite/bugs/closed/1951.v b/test-suite/bugs/closed/1951.v new file mode 100644 index 00000000..7558b0b8 --- /dev/null +++ b/test-suite/bugs/closed/1951.v @@ -0,0 +1,63 @@ + +(* First a simplification of the bug *) + +Set Printing Universes. + +Inductive enc (A:Type (*1*)) (* : Type.1 *) := C : A -> enc A. + +Definition id (X:Type(*4*)) (x:X) := x. + +Lemma test : let S := Type(*5 : 6*) in enc S -> S. +simpl; intros. +refine (enc _). +apply id. +apply Prop. +Defined. + +(* Then the original bug *) + +Require Import List. + +Inductive a : Set := (* some dummy inductive *) +b : (list a) -> a. (* i don't know if this *) + (* happens for smaller *) + (* ones *) + +Inductive sg : Type := Sg. (* single *) + +Definition ipl2 (P : a -> Type) := (* in Prop, that means P is true forall *) + fold_right (fun x => fun A => prod (P x) A) sg. (* the elements of a given list *) + +Definition ind + : forall S : a -> Type, + (forall ls : list a, ipl2 S ls -> S (b ls)) -> forall s : a, S s := +fun (S : a -> Type) + (X : forall ls : list a, ipl2 S ls -> S (b ls)) => +fix ind2 (s : a) := +match s as a return (S a) with +| b l => + X l + (list_rect (fun l0 : list a => ipl2 S l0) Sg + (fun (a0 : a) (l0 : list a) (IHl : ipl2 S l0) => + pair (ind2 a0) IHl) l) +end. (* some induction principle *) + +Implicit Arguments ind [S]. + +Lemma k : a -> Type. (* some ininteresting lemma *) +intro;pattern H;apply ind;intros. + assert (K : Type). + induction ls. + exact sg. + exact sg. + exact (prod K sg). +Defined. + +Lemma k' : a -> Type. (* same lemma but with our bug *) +intro;pattern H;apply ind;intros. + refine (prod _ _). + induction ls. + exact sg. + exact sg. + exact sg. (* Proof complete *) +Defined. (* bug *) diff --git a/test-suite/bugs/closed/1962.v b/test-suite/bugs/closed/1962.v new file mode 100644 index 00000000..a6b0fee5 --- /dev/null +++ b/test-suite/bugs/closed/1962.v @@ -0,0 +1,55 @@ +(* Bug 1962.v + +Bonjour, + +J'ai un exemple de lemme que j'arrivais à prouver avec fsetdec avec la 8.2beta3 +avec la beta4 et la version svn 11447 branche 8.2 çà diverge. + +Voici l'exemple en question, l'exmple test2 marche bien dans les deux version, +test en revanche pose probleme: + +*) + +Require Export FSets. + +(** This module takes a decidable type and +build finite sets of this type, tactics and defs *) + +Module BuildFSets (DecPoints: UsualDecidableType). + +Module Export FiniteSetsOfPoints := FSetWeakList.Make DecPoints. +Module Export FiniteSetsOfPointsProperties := + WProperties FiniteSetsOfPoints. +Module Export Dec := WDecide FiniteSetsOfPoints. +Module Export FM := Dec.F. + +Definition set_of_points := t. +Definition Point := DecPoints.t. + +Definition couple(x y :Point) : set_of_points := +add x (add y empty). + +Definition triple(x y t :Point): set_of_points := +add x (add y (add t empty)). + +Lemma test : forall P A B C A' B' C', +Equal +(union (singleton P) (union (triple A B C) (triple A' B' C'))) +(union (triple P B B') (union (couple P A) (triple C A' C'))). +Proof. +intros. +unfold triple, couple. +Time fsetdec. (* works in 8.2 beta 3, not in beta 4 and final 8.2 *) + (* appears to works again in 8.3 and trunk, take 4-6 seconds *) +Qed. + +Lemma test2 : forall A B C, +Equal + (union (singleton C) (couple A B)) (triple A B C). +Proof. +intros. +unfold triple, couple. +Time fsetdec. +Qed. + +End BuildFSets. \ No newline at end of file diff --git a/test-suite/bugs/closed/1963.v b/test-suite/bugs/closed/1963.v new file mode 100644 index 00000000..11e2ee44 --- /dev/null +++ b/test-suite/bugs/closed/1963.v @@ -0,0 +1,19 @@ +(* Check that "dependent inversion" behaves correctly w.r.t to universes *) + +Require Import Eqdep. + +Set Implicit Arguments. + +Inductive illist(A:Type) : nat -> Type := + illistn : illist A 0 +| illistc : forall n:nat, A -> illist A n -> illist A (S n). + +Inductive isig (A:Type)(P:A -> Type) : Type := + iexists : forall x : A, P x -> isig P. + +Lemma inv : forall (A:Type)(n n':nat)(ts':illist A n'), n' = S n -> + isig (fun t => isig (fun ts => + eq_dep nat (fun n => illist A n) n' ts' (S n) (illistc t ts))). +Proof. +intros. +dependent inversion ts'. diff --git a/test-suite/bugs/closed/1977.v b/test-suite/bugs/closed/1977.v new file mode 100644 index 00000000..28715040 --- /dev/null +++ b/test-suite/bugs/closed/1977.v @@ -0,0 +1,4 @@ +Inductive T {A} : Prop := c : A -> T. +Goal (@T nat). +apply c. exact 0. +Qed. diff --git a/test-suite/bugs/closed/1981.v b/test-suite/bugs/closed/1981.v new file mode 100644 index 00000000..99952682 --- /dev/null +++ b/test-suite/bugs/closed/1981.v @@ -0,0 +1,5 @@ +Implicit Arguments ex_intro [A]. + +Goal exists n : nat, True. + eapply ex_intro. exact 0. exact I. +Qed. diff --git a/test-suite/bugs/closed/2001.v b/test-suite/bugs/closed/2001.v new file mode 100644 index 00000000..d0b3bf17 --- /dev/null +++ b/test-suite/bugs/closed/2001.v @@ -0,0 +1,22 @@ +(* Automatic computing of guard in "Theorem with"; check that guard is not + computed when the user explicitly indicated it *) + +Unset Automatic Introduction. + +Inductive T : Set := +| v : T. + +Definition f (s:nat) (t:T) : nat. +fix 2. +intros s t. +refine + match t with + | v => s + end. +Defined. + +Lemma test : + forall s, f s v = s. +Proof. +reflexivity. +Qed. diff --git a/test-suite/bugs/closed/2006.v b/test-suite/bugs/closed/2006.v new file mode 100644 index 00000000..d353d0e2 --- /dev/null +++ b/test-suite/bugs/closed/2006.v @@ -0,0 +1,23 @@ +(* Take the type constraint on Record into account *) + +Definition Type1 := Type. +Fail Record R : Type1 := { p:Type1 }. (* was accepted before trunk revision 11619 *) + +(* +Remarks: + +- The behaviour was inconsistent with the one of Inductive, e.g. + + Inductive R : Type1 := Build_R : Type1 -> R. + + was correctly refused. + +- CoRN makes some use of the following configuration: + + Definition CProp := Type. + Record R : CProp := { ... }. + + CoRN may have to change the CProp definition into a notation if the + preservation of the former semantics of Record type constraints + turns to be required. +*) diff --git a/test-suite/bugs/closed/2017.v b/test-suite/bugs/closed/2017.v new file mode 100644 index 00000000..df666148 --- /dev/null +++ b/test-suite/bugs/closed/2017.v @@ -0,0 +1,15 @@ +(* Some check of Miller's pattern inference - used to fail in 8.2 due + first to the presence of aliases, secondly due to the absence of + restriction of the potential interesting variables to the subset of + variables effectively occurring in the term to instantiate *) + +Set Implicit Arguments. + +Variable choose : forall(P : bool -> Prop)(H : exists x, P x), bool. + +Variable H : exists x : bool, True. + +Definition coef := +match Some true with + Some _ => @choose _ H |_ => true +end . diff --git a/test-suite/bugs/closed/2021.v b/test-suite/bugs/closed/2021.v new file mode 100644 index 00000000..e598e5ae --- /dev/null +++ b/test-suite/bugs/closed/2021.v @@ -0,0 +1,23 @@ +(* correct failure of injection/discriminate on types whose inductive + status derives from the substitution of an argument *) + +Inductive t : nat -> Type := +| M : forall n: nat, nat -> t n. + +Lemma eq_t : forall n n' m m', + existT (fun B : Type => B) (t n) (M n m) = + existT (fun B : Type => B) (t n') (M n' m') -> True. +Proof. + intros. + injection H. + intro Ht. + exact I. +Qed. + +Lemma eq_t' : forall n n' : nat, + existT (fun B : Type => B) (t n) (M n 0) = + existT (fun B : Type => B) (t n') (M n' 1) -> True. +Proof. + intros. + discriminate H || exact I. +Qed. diff --git a/test-suite/bugs/closed/2027.v b/test-suite/bugs/closed/2027.v new file mode 100644 index 00000000..fb53c6ef --- /dev/null +++ b/test-suite/bugs/closed/2027.v @@ -0,0 +1,11 @@ + +Parameter T : Type -> Type. +Parameter f : forall {A}, T A -> T A. +Parameter P : forall {A}, T A -> Prop. +Axiom f_id : forall {A} (l : T A), f l = l. + +Goal forall A (p : T A), P p. +Proof. + intros. + rewrite <- f_id. +Admitted. \ No newline at end of file diff --git a/test-suite/bugs/closed/2083.v b/test-suite/bugs/closed/2083.v new file mode 100644 index 00000000..5f17f7af --- /dev/null +++ b/test-suite/bugs/closed/2083.v @@ -0,0 +1,27 @@ +Require Import Program Arith. + +Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) + (H : forall (i : { i | i < n }), i < p -> P i = true) + {measure (n - p)} : + Exc (forall (p : { i | i < n}), P p = true) := + match le_lt_dec n p with + | left _ => value _ + | right cmp => + if dec (P p) then + check_n n P (S p) _ + else + error + end. + +Require Import Omega. + +Solve Obligations with program_simpl ; auto with *; try omega. + +Next Obligation. + apply H. simpl. omega. +Defined. + +Next Obligation. + case (le_lt_dec p i) ; intros. assert(i = p) by omega. subst. + revert H0. clear_subset_proofs. auto. + apply H. simpl. assumption. Defined. diff --git a/test-suite/bugs/closed/2089.v b/test-suite/bugs/closed/2089.v new file mode 100644 index 00000000..aebccc94 --- /dev/null +++ b/test-suite/bugs/closed/2089.v @@ -0,0 +1,17 @@ +Inductive even (x: nat): nat -> Prop := + | even_base: even x O + | even_succ: forall n, odd x n -> even x (S n) + +with odd (x: nat): nat -> Prop := + | odd_succ: forall n, even x n -> odd x (S n). + +Scheme even_ind2 := Minimality for even Sort Prop + with odd_ind2 := Minimality for odd Sort Prop. + +Combined Scheme even_odd_ind from even_ind2, odd_ind2. + +Check (even_odd_ind :forall (x : nat) (P P0 : nat -> Prop), + P 0 -> + (forall n : nat, odd x n -> P0 n -> P (S n)) -> + (forall n : nat, even x n -> P n -> P0 (S n)) -> + (forall n : nat, even x n -> P n) /\ (forall n : nat, odd x n -> P0 n)). diff --git a/test-suite/bugs/closed/2095.v b/test-suite/bugs/closed/2095.v new file mode 100644 index 00000000..28ea99df --- /dev/null +++ b/test-suite/bugs/closed/2095.v @@ -0,0 +1,19 @@ +(* Classes and sections *) + +Section OPT. + Variable A: Type. + + Inductive MyOption: Type := + | MyNone: MyOption + | MySome: A -> MyOption. + + Class Opt: Type := { + f_opt: A -> MyOption + }. +End OPT. + +Definition f_nat (n: nat): MyOption nat := MySome _ n. + +Instance Nat_Opt: Opt nat := { + f_opt := f_nat +}. diff --git a/test-suite/bugs/closed/2108.v b/test-suite/bugs/closed/2108.v new file mode 100644 index 00000000..cad8baa9 --- /dev/null +++ b/test-suite/bugs/closed/2108.v @@ -0,0 +1,22 @@ +(* Declare Module in Module Type *) +Module Type A. +Record t : Set := { something : unit }. +End A. + + +Module Type B. +Declare Module BA : A. +End B. + + +Module Type C. +Declare Module CA : A. +Declare Module CB : B with Module BA := CA. +End C. + + +Module Type D. +Declare Module DA : A. +(* Next line gives: "Anomaly: uncaught exception Not_found. Please report." *) +Declare Module DC : C with Module CA := DA. +End D. diff --git a/test-suite/bugs/closed/2117.v b/test-suite/bugs/closed/2117.v new file mode 100644 index 00000000..6377a8b7 --- /dev/null +++ b/test-suite/bugs/closed/2117.v @@ -0,0 +1,56 @@ +(* Check pattern-unification on evars in apply unification *) + +Axiom app : forall tau tau':Type, (tau -> tau') -> tau -> tau'. + +Axiom copy : forall tau:Type, tau -> tau -> Prop. +Axiom copyr : forall tau:Type, tau -> tau -> Prop. +Axiom copyf : forall tau:Type, tau -> tau -> Prop. +Axiom eq : forall tau:Type, tau -> tau -> Prop. +Axiom subst : forall tau tau':Type, (tau -> tau') -> tau -> tau' -> Prop. + +Axiom copy_atom : forall tau:Type, forall t t':tau, eq tau t t' -> copy tau t t'. +Axiom copy_fun: forall tau tau':Type, forall t t':(tau->tau'), +(forall x:tau, copyr tau x x->copy tau' (t x) (t' x)) +->copy (tau->tau') t t'. + +Axiom copyr_atom : forall tau:Type, forall t t':tau, copyr tau t t' -> eq tau t t'. +Axiom copyr_fun: forall tau tau':Type, forall t t':(tau->tau'), +copyr (tau->tau') t t' +->(forall x y:tau, copy tau x y->copyr tau' (t x) (t' y)). + +Axiom copyf_atom : forall tau:Type, forall t t':tau, copyf tau t t' -> eq tau t t'. +Axiom copyf_fun: forall tau tau':Type, forall t t':(tau->tau'), +copyr (tau->tau') t t' +->(forall x y:tau, forall z1 z2:tau', +(copy tau x y)-> +(subst tau tau' t x z1)-> +(subst tau tau' t' y z2)-> +copyf tau' z1 z2). + +Axiom eqappg: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau',forall t':tau', +( ((subst tau tau' t q t') /\ (eq tau' t' r)) +->eq tau' (app tau tau' t q) r). + +Axiom eqappd: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau', +forall t':tau', ((subst tau tau' t q t') /\ (eq tau' r t')) +->eq tau' r (app tau tau' t q). + +Axiom substcopy: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau', +(forall x:tau, (copyf tau x q) -> (copy tau' (t x) r)) +->subst tau tau' t q r. + +Ltac EtaLong := (apply copy_fun;intros;EtaLong)|| apply copy_atom. +Ltac Subst := apply substcopy;intros;EtaLong. +Ltac Rigid_aux := fun A => apply A|| Rigid_aux (copyr_fun _ _ _ _ A). +Ltac Rigid := fun A => apply copyr_atom; Rigid_aux A. + +Theorem church0: forall i:Type, exists X:(i->i)->i->i, +copy ((i->i)->i->i) (fun f:i->i => fun x:i=>f (X f x)) (fun f:i->i=>fun x:i=>app i i (X f) (f x)). +intros. +esplit. +EtaLong. +eapply eqappd;split. +Subst. +apply copyf_atom. +Show Existentials. +apply H1. diff --git a/test-suite/bugs/closed/2123.v b/test-suite/bugs/closed/2123.v new file mode 100644 index 00000000..422a2c12 --- /dev/null +++ b/test-suite/bugs/closed/2123.v @@ -0,0 +1,11 @@ +(* About the detection of non-dependent metas by the refine tactic *) + +(* The following is a simplification of bug #2123 *) + +Parameter fset : nat -> Set. +Parameter widen : forall (n : nat) (s : fset n), { x : fset (S n) | s=s }. +Goal forall i, fset (S i). +intro. +refine (proj1_sig (widen i _)). + + diff --git a/test-suite/bugs/closed/2127.v b/test-suite/bugs/closed/2127.v new file mode 100644 index 00000000..142ada26 --- /dev/null +++ b/test-suite/bugs/closed/2127.v @@ -0,0 +1,8 @@ +(* Check that "apply eq_refl" is not exported as an interactive + tactic but as a statically globalized one *) + +(* (this is a simplification of the original bug report) *) + +Module A. +Hint Rewrite eq_sym using apply eq_refl : foo. +End A. diff --git a/test-suite/bugs/closed/2135.v b/test-suite/bugs/closed/2135.v new file mode 100644 index 00000000..61882176 --- /dev/null +++ b/test-suite/bugs/closed/2135.v @@ -0,0 +1,9 @@ +(* Check that metas are whd-normalized before trying 2nd-order unification *) +Lemma test : + forall (D:Type) (T : forall C, option C) (Q:forall D, option D -> Prop), + (forall (A : Type) (P : forall B:Type, option B -> Prop), P A (T A)) + -> Q D (T D). +Proof. + intros D T Q H. + pattern (T D). apply H. +Qed. diff --git a/test-suite/bugs/closed/2136.v b/test-suite/bugs/closed/2136.v new file mode 100644 index 00000000..d2b926f3 --- /dev/null +++ b/test-suite/bugs/closed/2136.v @@ -0,0 +1,61 @@ +(* Bug #2136 + +The fsetdec tactic seems to get confused by hypotheses like + HeqH1 : H1 = MkEquality s0 s1 b +If I clear them then it is able to solve my goal; otherwise it is not. +I would expect it to be able to solve the goal even without this hypothesis +being cleared. A small, self-contained example is below. + +I have coq r12238. + + +Thanks +Ian +*) + + +Require Import FSets. +Require Import Arith. +Require Import FSetWeakList. + +Module DecidableNat. +Definition t := nat. +Definition eq := @eq nat. +Definition eq_refl := @refl_equal nat. +Definition eq_sym := @sym_eq nat. +Definition eq_trans := @trans_eq nat. +Definition eq_dec := eq_nat_dec. +End DecidableNat. + +Module NatSet := Make(DecidableNat). + +Module Export Dec := WDecide (NatSet). +Import FSetDecideAuxiliary. + +Parameter MkEquality : forall ( s0 s1 : NatSet.t ) + ( x : nat ), + NatSet.Equal s1 (NatSet.add x s0). + +Lemma ThisLemmaWorks : forall ( s0 s1 : NatSet.t ) + ( a b : nat ), + NatSet.In a s0 + -> NatSet.In a s1. +Proof. +intros. +remember (MkEquality s0 s1 b) as H1. +clear HeqH1. +fsetdec. +Qed. + +Lemma ThisLemmaWasFailing : forall ( s0 s1 : NatSet.t ) + ( a b : nat ), + NatSet.In a s0 + -> NatSet.In a s1. +Proof. +intros. +remember (MkEquality s0 s1 b) as H1. +fsetdec. +(* +Error: Tactic failure: because the goal is beyond the scope of this tactic. +*) +Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/2137.v b/test-suite/bugs/closed/2137.v new file mode 100644 index 00000000..6c2023ab --- /dev/null +++ b/test-suite/bugs/closed/2137.v @@ -0,0 +1,52 @@ +(* Bug #2137 + +The fsetdec tactic is sensitive to which way round the arguments to <> are. +In the small, self-contained example below, it is able to solve the goal +if it knows that "b <> a", but not if it knows that "a <> b". I would expect +it to be able to solve hte goal in either case. + +I have coq r12238. + + +Thanks +Ian + +*) + +Require Import Arith FSets FSetWeakList. + +Module DecidableNat. +Definition t := nat. +Definition eq := @eq nat. +Definition eq_refl := @refl_equal nat. +Definition eq_sym := @sym_eq nat. +Definition eq_trans := @trans_eq nat. +Definition eq_dec := eq_nat_dec. +End DecidableNat. + +Module NatSet := Make(DecidableNat). + +Module Export NameSetDec := WDecide (NatSet). + +Lemma ThisLemmaWorks : forall ( s0 : NatSet.t ) + ( a b : nat ), + b <> a + -> ~(NatSet.In a s0) + -> ~(NatSet.In a (NatSet.add b s0)). +Proof. +intros. +fsetdec. +Qed. + +Lemma ThisLemmaWasFailing : forall ( s0 : NatSet.t ) + ( a b : nat ), + a <> b + -> ~(NatSet.In a s0) + -> ~(NatSet.In a (NatSet.add b s0)). +Proof. +intros. +fsetdec. +(* +Error: Tactic failure: because the goal is beyond the scope of this tactic. +*) +Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/2139.v b/test-suite/bugs/closed/2139.v new file mode 100644 index 00000000..a7f35508 --- /dev/null +++ b/test-suite/bugs/closed/2139.v @@ -0,0 +1,24 @@ +(* Call of apply on <-> failed because of evars in elimination predicate *) +Generalizable Variables patch. + +Class Patch (patch : Type) := { + commute : patch -> patch -> Prop +}. + +Parameter flip : forall `{patchInstance : Patch patch} + {a b : patch}, + commute a b <-> commute b a. + +Lemma Foo : forall `{patchInstance : Patch patch} + {a b : patch}, + (commute a b) + -> True. +Proof. +intros. +apply flip in H. + +(* failed in well-formed arity check because elimination predicate of + iff in (@flip _ _ _ _) had normalized evars while the ones in the + type of (@flip _ _ _ _) itself had non-normalized evars *) + +(* By the way, is the check necessary ? *) diff --git a/test-suite/bugs/closed/2141.v b/test-suite/bugs/closed/2141.v new file mode 100644 index 00000000..941ae530 --- /dev/null +++ b/test-suite/bugs/closed/2141.v @@ -0,0 +1,14 @@ +Require Import FSetList. +Require Import OrderedTypeEx. + +Module NatSet := FSetList.Make (Nat_as_OT). +Recursive Extraction NatSet.fold. + +Module FSetHide (X : FSetInterface.S). + Include X. +End FSetHide. + +Module NatSet' := FSetHide NatSet. +Recursive Extraction NatSet'.fold. + +(* Extraction "test2141.ml" NatSet'.fold. *) \ No newline at end of file diff --git a/test-suite/bugs/closed/2145.v b/test-suite/bugs/closed/2145.v new file mode 100644 index 00000000..4dc0de74 --- /dev/null +++ b/test-suite/bugs/closed/2145.v @@ -0,0 +1,20 @@ +(* Test robustness of Groebner tactic in presence of disequalities *) + +Require Export Reals. +Require Export Nsatz. + +Open Scope R_scope. + +Lemma essai : + forall yb xb m1 m2 xa ya, + xa <> xb -> + yb - 2 * m2 * xb = ya - m2 * xa -> + yb - m1 * xb = ya - m1 * xa -> + yb - ya = (2 * xb - xa) * m2 -> + yb - ya = (xb - xa) * m1. +Proof. +intros. +(* clear H. groebner used not to work when H was not cleared *) +nsatz. +Qed. + diff --git a/test-suite/bugs/closed/2149.v b/test-suite/bugs/closed/2149.v new file mode 100644 index 00000000..38c5f36a --- /dev/null +++ b/test-suite/bugs/closed/2149.v @@ -0,0 +1,7 @@ +Lemma Foo : forall x y : nat, y = x -> y = x. +Proof. +intros x y. +rename x into y, y into x. +trivial. +Qed. + diff --git a/test-suite/bugs/closed/2164.v b/test-suite/bugs/closed/2164.v new file mode 100644 index 00000000..6adb3577 --- /dev/null +++ b/test-suite/bugs/closed/2164.v @@ -0,0 +1,334 @@ +(* Check that "inversion as" manages names as expected *) +Inductive type: Set + := | int: type + | pointer: type -> type. +Print type. + +Parameter value_set + : type -> Set. + +Parameter string : Set. + +Parameter Z : Set. + +Inductive lvalue (t: type): Set + := | var: string -> lvalue t (* name of the variable *) + | lvalue_loc: Z -> lvalue t (* address of the variable *) + | deref_l: lvalue (pointer t) -> lvalue t (* deref an lvalue ptr *) + | deref_r: rvalue (pointer t) -> lvalue t (* deref an rvalue ptr *) +with rvalue (t: type): Set + := | value_of: lvalue t -> rvalue t (* variable as value *) + | mk_rvalue: value_set t -> rvalue t. (* literal value *) +Print lvalue. + +Inductive statement: Set + := | void_stat: statement + | var_loc: (* to be destucted at end of scope *) + forall (t: type) (n: string) (loc: Z), statement + | var_ref: (* not to be destructed *) + forall (t: type) (n: string) (loc: Z), statement + | var_def: (* var def as typed in code *) + forall (t:type) (n: string) (val: rvalue t), statement + | assign: + forall (t: type) (var: lvalue t) (val: rvalue t), statement + | group: + forall (l: list statement), statement + | fun_def: + forall (s: string) (l: list statement), statement + | param_decl: + forall (t: type) (n: string), statement + | delete: + forall a: Z, statement. + +Inductive expr: Set +:= | statement_to_expr: statement -> expr + | lvalue_to_expr: forall t: type, lvalue t -> expr + | rvalue_to_expr: forall t: type, rvalue t -> expr. + +Inductive executable_prim_expr: expr -> Set +:= +(* statements *) + | var_def_primitive: + forall (t: type) (n: string) (loc: Z), + executable_prim_expr + (statement_to_expr + (var_def t n + (value_of t (lvalue_loc t loc)))) + | assign_primitive: + forall (t: type) (loc1 loc2: Z), + executable_prim_expr + (statement_to_expr + (assign t (lvalue_loc t loc1) + (value_of t (lvalue_loc t loc2)))) +(* rvalue *) + | mk_rvalue_primitive: + forall (t: type) (v: value_set t), + executable_prim_expr + (rvalue_to_expr t (mk_rvalue t v)) +(* lvalue *) + (* var *) + | var_primitive: + forall (t: type) (n: string), + executable_prim_expr (lvalue_to_expr t (var t n)) + (* deref_l *) + | deref_l_primitive: + forall (t: type) (loc: Z), + executable_prim_expr + (lvalue_to_expr t + (deref_l t (lvalue_loc (pointer t) loc))) + (* deref_r *) + | deref_r_primitive: + forall (t: type) (loc: Z), + executable_prim_expr + (lvalue_to_expr t + (deref_r t + (value_of (pointer t) + (lvalue_loc (pointer t) loc)))). + +Inductive executable_sub_expr: expr -> Set +:= | executable_sub_expr_prim: + forall e: expr, + executable_prim_expr e -> + executable_sub_expr e +(* statements *) + | var_def_sub_rvalue: + forall (t: type) (n: string) (rv: rvalue t), + executable_sub_expr (rvalue_to_expr t rv) -> + executable_sub_expr (statement_to_expr (var_def t n rv)) + | assign_sub_lvalue: + forall (t: type) (lv: lvalue t) (rv: rvalue t), + executable_sub_expr (lvalue_to_expr t lv) -> + executable_sub_expr (statement_to_expr (assign t lv rv)) + | assign_sub_rvalue: + forall (t: type) (lv: lvalue t) (rv: rvalue t), + executable_sub_expr (rvalue_to_expr t rv) -> + executable_sub_expr (statement_to_expr (assign t lv rv)) +(* rvalue *) + | value_of_sub_lvalue: + forall (t: type) (lv: lvalue t), + executable_sub_expr (lvalue_to_expr t lv) -> + executable_sub_expr (rvalue_to_expr t (value_of t lv)) +(* lvalue *) + | deref_l_sub_lvalue: + forall (t: type) (lv: lvalue (pointer t)), + executable_sub_expr (lvalue_to_expr (pointer t) lv) -> + executable_sub_expr (lvalue_to_expr t (deref_l t lv)) + | deref_r_sub_rvalue: + forall (t: type) (rv: rvalue (pointer t)), + executable_sub_expr (rvalue_to_expr (pointer t) rv) -> + executable_sub_expr (lvalue_to_expr t (deref_r t rv)). + +Inductive expr_kind: Set +:= | statement_kind: expr_kind + | lvalue_kind: type -> expr_kind + | rvalue_kind: type -> expr_kind. + +Definition expr_to_kind: expr -> expr_kind. +intro e. +destruct e. +exact statement_kind. +exact (lvalue_kind t). +exact (rvalue_kind t). +Defined. + +Inductive def_sub_expr_subs: + forall e: expr, + forall ee: executable_sub_expr e, + forall ee': expr, + forall e': expr, + Prop +:= | def_sub_expr_subs_prim: + forall e: expr, + forall p: executable_prim_expr e, + forall ee': expr, + expr_to_kind e = expr_to_kind ee' -> + def_sub_expr_subs e (executable_sub_expr_prim e p) ee' ee' + | def_sub_expr_subs_var_def_sub_rvalue: + forall (t: type) (n: string), + forall rv rv': rvalue t, + forall ee': expr, + forall se_rv: executable_sub_expr (rvalue_to_expr t rv), + def_sub_expr_subs (rvalue_to_expr t rv) se_rv ee' + (rvalue_to_expr t rv') -> + def_sub_expr_subs + (statement_to_expr (var_def t n rv)) + (var_def_sub_rvalue t n rv se_rv) + ee' + (statement_to_expr (var_def t n rv')) + | def_sub_expr_subs_assign_sub_lvalue: + forall t: type, + forall lv lv': lvalue t, + forall rv: rvalue t, + forall ee': expr, + forall se_lv: executable_sub_expr (lvalue_to_expr t lv), + def_sub_expr_subs (lvalue_to_expr t lv) se_lv ee' + (lvalue_to_expr t lv') -> + def_sub_expr_subs + (statement_to_expr (assign t lv rv)) + (assign_sub_lvalue t lv rv se_lv) + ee' + (statement_to_expr (assign t lv' rv)) + | def_sub_expr_subs_assign_sub_rvalue: + forall t: type, + forall lv: lvalue t, + forall rv rv': rvalue t, + forall ee': expr, + forall se_rv: executable_sub_expr (rvalue_to_expr t rv), + def_sub_expr_subs (rvalue_to_expr t rv) se_rv ee' + (rvalue_to_expr t rv') -> + def_sub_expr_subs + (statement_to_expr (assign t lv rv)) + (assign_sub_rvalue t lv rv se_rv) + ee' + (statement_to_expr (assign t lv rv')) + | def_sub_expr_subs_value_of_sub_lvalue: + forall t: type, + forall lv lv': lvalue t, + forall ee': expr, + forall se_lv: executable_sub_expr (lvalue_to_expr t lv), + def_sub_expr_subs (lvalue_to_expr t lv) se_lv ee' + (lvalue_to_expr t lv') -> + def_sub_expr_subs + (rvalue_to_expr t (value_of t lv)) + (value_of_sub_lvalue t lv se_lv) + ee' + (rvalue_to_expr t (value_of t lv')) + | def_sub_expr_subs_deref_l_sub_lvalue: + forall t: type, + forall lv lv': lvalue (pointer t), + forall ee': expr, + forall se_lv: executable_sub_expr (lvalue_to_expr (pointer t) lv), + def_sub_expr_subs (lvalue_to_expr (pointer t) lv) se_lv ee' + (lvalue_to_expr (pointer t) lv') -> + def_sub_expr_subs + (lvalue_to_expr t (deref_l t lv)) + (deref_l_sub_lvalue t lv se_lv) + ee' + (lvalue_to_expr t (deref_l t lv')) + | def_sub_expr_subs_deref_r_sub_rvalue: + forall t: type, + forall rv rv': rvalue (pointer t), + forall ee': expr, + forall se_rv: executable_sub_expr (rvalue_to_expr (pointer t) rv), + def_sub_expr_subs (rvalue_to_expr (pointer t) rv) se_rv ee' + (rvalue_to_expr (pointer t) rv') -> + def_sub_expr_subs + (lvalue_to_expr t (deref_r t rv)) + (deref_r_sub_rvalue t rv se_rv) + ee' + (lvalue_to_expr t (deref_r t rv')). + +Lemma type_dec: forall t t': type, {t = t'} + {t <> t'}. +Proof. +intros t. +induction t as [|t IH]. +destruct t'. +tauto. +right. +discriminate. +destruct t'. +right. +discriminate. +destruct (IH t') as [H|H]. +left. +f_equal. +tauto. +right. +injection. +tauto. +Qed. +Check type_dec. + +Definition sigT_get_proof: + forall T: Type, + forall eq_dec_T: forall t t': T, {t = t'} + {~ t = t'}, + forall P: T -> Type, + forall t: T, + P t -> + sigT P -> + P t. +intros T eq_dec_T P t H1 H2. +destruct H2 as [t' H2]. +destruct (eq_dec_T t t') as [H3|H3]. +rewrite H3. +exact H2. +exact H1. +Defined. + +Axiom sigT_get_proof_existT_same: + forall T: Type, + forall eq_dec_T: forall t t': T, {t = t'} + {~ t = t'}, + forall P: T -> Type, + forall t: T, + forall H1 H2: P t, + sigT_get_proof T eq_dec_T P t H1 (existT P t H2) = H2. + +Theorem existT_injective: + forall T, + (forall t1 t2: T, { t1 = t2 } + { t1 <> t2 }) -> + forall P: T -> Type, + forall t: T, + forall pt1 pt2: P t, + existT P t pt1 = existT P t pt2 -> + pt1 = pt2. +Proof. +intros T T_dec P t pt1 pt2 H1. +pose (H2 := f_equal (sigT_get_proof T T_dec P t pt1) H1). +repeat rewrite sigT_get_proof_existT_same in H2. +assumption. +Qed. + +Ltac decide_equality_sub dec x x' H := + destruct (dec x x') as [H|H]; + [subst x'; try tauto|try(right; injection; tauto; fail)]. + +Axiom value_set_dec: + forall t: type, + forall v v': value_set t, + {v = v'} + {v <> v'}. + +Theorem lvalue_dec: + forall (t: type) (l l': lvalue t), {l = l'} + {l <> l'} +with rvalue_dec: + forall (t: type) (r r': rvalue t), {r = r'} + {r <> r'}. +Admitted. + +Theorem sub_expr_subs_same_kind: + forall e: expr, + forall ee: executable_sub_expr e, + forall ee': expr, + forall e': expr, + def_sub_expr_subs e ee ee' e' -> + expr_to_kind e = expr_to_kind e'. +Proof. +intros e ee ee' e' H1. +case H1; try (intros; tauto; fail). +Qed. + +Theorem def_sub_expr_subs_assign_sub_lvalue_inversion: + forall t: type, + forall lv: lvalue t, + forall rv: rvalue t, + forall ee' e': expr, + forall ee_sub: executable_sub_expr (lvalue_to_expr t lv), + def_sub_expr_subs (statement_to_expr (assign t lv rv)) + (assign_sub_lvalue t lv rv ee_sub) ee' e' -> + { lv': lvalue t + | def_sub_expr_subs (lvalue_to_expr t lv) ee_sub ee' + (lvalue_to_expr t lv') + & e' = statement_to_expr (assign t lv' rv) }. +Proof. +intros t lv rv ee' [s'|t' lv''|t' rv''] ee_sub H1; + try discriminate (sub_expr_subs_same_kind _ _ _ _ H1). +destruct s' as [| | | |t' lv'' rv''| | | |]; + try(assert (H2: False); [inversion H1|elim H2]; fail). +destruct (type_dec t t') as [H2|H2]; + [|assert (H3: False); + [|elim H3; fail]]. +2: inversion H1 as [];tauto. +subst t'. +exists lv''. + inversion H1 as + [| |t' lv''' lv'''' rv''' ee'' ee_sub' H2 (H3_1,H3_2,H3_3) (H4_1,H4_2,H4_3,H4_4,H4_5) H5 (H6_1,H6_2)| | | |]. +(* Check that all names are the given ones: *) +clear t' lv''' lv'''' rv''' ee'' ee_sub' H2 H3_1 H3_2 H3_3 H4_1 H4_2 H4_3 H4_4 H4_5 H5 H6_1 H6_2. diff --git a/test-suite/bugs/closed/2181.v b/test-suite/bugs/closed/2181.v new file mode 100644 index 00000000..62820d86 --- /dev/null +++ b/test-suite/bugs/closed/2181.v @@ -0,0 +1,3 @@ +Class C. +Parameter P: C -> Prop. +Fail Record R: Type := { _: C; u: P _ }. diff --git a/test-suite/bugs/closed/2193.v b/test-suite/bugs/closed/2193.v new file mode 100644 index 00000000..fe258867 --- /dev/null +++ b/test-suite/bugs/closed/2193.v @@ -0,0 +1,31 @@ +(* Computation of dependencies in the "match" return predicate was incomplete *) +(* Submitted by R. O'Connor, Nov 2009 *) + +Inductive Symbol : Set := + | VAR : Symbol. + +Inductive SExpression := + | atomic : Symbol -> SExpression. + +Inductive ProperExpr : SExpression -> SExpression -> Type := + | pe_3 : forall (x : Symbol) (alpha : SExpression), + ProperExpr alpha (atomic VAR) -> + ProperExpr (atomic x) alpha. + +Definition A (P : forall s : SExpression, Type) + (x alpha alpha1 : SExpression) + (t : ProperExpr (x) alpha1) : option (x = atomic VAR) := + match t as pe in ProperExpr a b return option (a = atomic VAR) with + | pe_3 x0 alpha3 tye' => + (fun (x:Symbol) (alpha : SExpression) => @None (atomic x = atomic VAR)) + x0 alpha3 + end. + +Definition B (P : forall s : SExpression, Type) + (x alpha alpha1 : SExpression) + (t : ProperExpr (x) alpha1) : option (x = atomic VAR) := + match t as pe in ProperExpr a b return option (a = atomic VAR) with + | pe_3 x0 alpha3 tye' => + (fun (x:Symbol) (alpha : SExpression) (t:ProperExpr alpha (atomic VAR)) => @None (atomic x = atomic VAR)) + x0 alpha3 tye' + end. diff --git a/test-suite/bugs/closed/2230.v b/test-suite/bugs/closed/2230.v new file mode 100644 index 00000000..5076fb2b --- /dev/null +++ b/test-suite/bugs/closed/2230.v @@ -0,0 +1,6 @@ +Goal forall f, f 1 1 -> True. +intros. +match goal with + | [ H : _ ?a |- _ ] => idtac +end. +Abort. diff --git a/test-suite/bugs/closed/2231.v b/test-suite/bugs/closed/2231.v new file mode 100644 index 00000000..03e2c9bb --- /dev/null +++ b/test-suite/bugs/closed/2231.v @@ -0,0 +1,3 @@ +Inductive unit2 : Type := U : unit -> unit2. +Inductive dummy (u: unit2) : unit -> Type := + V: dummy u (let (tt) := u in tt). diff --git a/test-suite/bugs/closed/2244.v b/test-suite/bugs/closed/2244.v new file mode 100644 index 00000000..d499e515 --- /dev/null +++ b/test-suite/bugs/closed/2244.v @@ -0,0 +1,19 @@ +(* 1st-order unification did not work when in competition with pattern unif. *) + +Set Implicit Arguments. +Lemma test : forall + (A : Type) + (B : Type) + (f : A -> B) + (S : B -> Prop) + (EV : forall y (f':A->B), (forall x', S (f' x')) -> S (f y)) + (HS : forall x', S (f x')) + (x : A), + S (f x). +Proof. + intros. eapply EV. intros. + (* worked in v8.2 but not in v8.3beta, fixed in r12898 *) + apply HS. + + (* still not compatible with 8.2 because an evar can be solved in + two different ways and is left open *) diff --git a/test-suite/bugs/closed/2250.v b/test-suite/bugs/closed/2250.v new file mode 100644 index 00000000..565d7b68 --- /dev/null +++ b/test-suite/bugs/closed/2250.v @@ -0,0 +1,3 @@ +Check prod: Prop -> Prop -> Prop. +(* (fun A B : Prop => (A * B)%type):Prop -> Prop -> Prop + : Prop -> Prop -> Prop *) diff --git a/test-suite/bugs/closed/2251.v b/test-suite/bugs/closed/2251.v new file mode 100644 index 00000000..d0fa3f2b --- /dev/null +++ b/test-suite/bugs/closed/2251.v @@ -0,0 +1,6 @@ +(* Check that rewrite does not apply to single evars *) + +Lemma evar_rewrite : (forall a : nat, a = 0 -> True) -> True. +intros; eapply H. (* goal is ?30 = nil *) +Fail rewrite plus_n_Sm. +Abort. diff --git a/test-suite/bugs/closed/2255.v b/test-suite/bugs/closed/2255.v new file mode 100644 index 00000000..bf80ff66 --- /dev/null +++ b/test-suite/bugs/closed/2255.v @@ -0,0 +1,21 @@ +(* Check injection in presence of dependencies hidden in applicative terms *) + +Inductive TupleT : nat -> Type := + nilT : TupleT 0 +| consT {n} A : (A -> TupleT n) -> TupleT (S n). + +Inductive Tuple : forall n, TupleT n -> Type := + nil : Tuple _ nilT +| cons {n} A (x : A) (F : A -> TupleT n) : Tuple _ (F x) -> Tuple _ (consT A F). + +Goal forall n A F x X n0 A0 x0 F0 H0 (H : existT (fun n0 : nat => {H0 : TupleT +n0 & Tuple n0 H0}) + (S n0) + (existT (fun H0 : TupleT (S n0) => Tuple (S n0) H0) + (consT A0 F0) (cons A0 x0 F0 H0)) = + existT (fun n0 : nat => {H0 : TupleT n0 & Tuple n0 H0}) + (S n) + (existT (fun H0 : TupleT (S n) => Tuple (S n) H0) + (consT A F) (cons A x F X))), False. +intros. +injection H. diff --git a/test-suite/bugs/closed/2262.v b/test-suite/bugs/closed/2262.v new file mode 100644 index 00000000..b61f18b8 --- /dev/null +++ b/test-suite/bugs/closed/2262.v @@ -0,0 +1,11 @@ + + +Generalizable Variables A. +Class Test A := { test : A }. + +Lemma mylemma : forall `{Test A}, test = test. +Admitted. (* works fine *) + +Definition mylemma' := forall `{Test A}, test = test. +About mylemma'. + diff --git a/test-suite/bugs/closed/2281.v b/test-suite/bugs/closed/2281.v new file mode 100644 index 00000000..40948d90 --- /dev/null +++ b/test-suite/bugs/closed/2281.v @@ -0,0 +1,50 @@ +(** Bug #2281 + +In the code below, coq is confused by an equality unless it is first 'subst'ed +away, yet http://coq.inria.fr/stdlib/Coq.FSets.FSetDecide.html says + + fsetdec will first perform any necessary zeta and beta reductions and will +invoke subst to eliminate any Coq equalities between finite sets or their +elements. + +I have coq r12851. + +*) + +Require Import Arith. +Require Import FSets. +Require Import FSetWeakList. + +Module DecidableNat. +Definition t := nat. +Definition eq := @eq nat. +Definition eq_refl := @refl_equal nat. +Definition eq_sym := @sym_eq nat. +Definition eq_trans := @trans_eq nat. +Definition eq_dec := eq_nat_dec. +End DecidableNat. + +Module NatSet := Make(DecidableNat). + +Module Export NameSetDec := WDecide (NatSet). + +Lemma ThisLemmaWorks : forall ( s1 s2 : NatSet.t ) + ( H : s1 = s2 ), + NatSet.Equal s1 s2. +Proof. +intros. +subst. +fsetdec. +Qed. + +Import FSetDecideAuxiliary. + +Lemma ThisLemmaWasFailing : forall ( s1 s2 : NatSet.t ) + ( H : s1 = s2 ), + NatSet.Equal s1 s2. +Proof. +intros. +fsetdec. +(* Error: Tactic failure: because the goal is beyond the scope of this tactic. +*) +Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/2295.v b/test-suite/bugs/closed/2295.v new file mode 100644 index 00000000..f5ca28dc --- /dev/null +++ b/test-suite/bugs/closed/2295.v @@ -0,0 +1,11 @@ +(* Check if omission of "as" in return clause works w/ section variables too *) + +Section sec. + +Variable b: bool. + +Definition d' := + (match b return b = true \/ b = false with + | true => or_introl _ (refl_equal true) + | false => or_intror _ (refl_equal false) + end). diff --git a/test-suite/bugs/closed/2299.v b/test-suite/bugs/closed/2299.v new file mode 100644 index 00000000..c0552ca7 --- /dev/null +++ b/test-suite/bugs/closed/2299.v @@ -0,0 +1,13 @@ +(* Check that destruct refreshes universes in what it generalizes *) + +Section test. + +Variable A: Type. + +Inductive T: unit -> Type := C: A -> unit -> T tt. + +Let unused := T tt. + +Goal T tt -> False. + intro X. + destruct X. diff --git a/test-suite/bugs/closed/2300.v b/test-suite/bugs/closed/2300.v new file mode 100644 index 00000000..4e587cbb --- /dev/null +++ b/test-suite/bugs/closed/2300.v @@ -0,0 +1,15 @@ +(* Check some behavior of Ltac pattern-matching wrt universe levels *) + +Section contents. + +Variables (A: Type) (B: (unit -> Type) -> Type). + +Inductive C := c: A -> unit -> C. + +Let unused2 (x: unit) := C. + +Goal True. +intuition. +Qed. + +End contents. diff --git a/test-suite/bugs/closed/2303.v b/test-suite/bugs/closed/2303.v new file mode 100644 index 00000000..e614b9b5 --- /dev/null +++ b/test-suite/bugs/closed/2303.v @@ -0,0 +1,4 @@ +Class A := a: unit. +Class B (x: unit). +Axiom H: forall x: A, @B x -> x = x -> unit. +Definition Field (z: A) (m: @B z) x := (@H _ _ x) = z. diff --git a/test-suite/bugs/closed/2304.v b/test-suite/bugs/closed/2304.v new file mode 100644 index 00000000..1ac2702b --- /dev/null +++ b/test-suite/bugs/closed/2304.v @@ -0,0 +1,4 @@ +(* This used to fail with an anomaly NotASort at some time *) +Class A (O: Type): Type := a: O -> Type. +Fail Goal forall (x: a tt), @a x = @a x. + diff --git a/test-suite/bugs/closed/2307.v b/test-suite/bugs/closed/2307.v new file mode 100644 index 00000000..7c049495 --- /dev/null +++ b/test-suite/bugs/closed/2307.v @@ -0,0 +1,3 @@ +Inductive V: nat -> Type := VS n: V (S n). +Definition f (e: V 1): nat := match e with VS 0 => 3 end. + diff --git a/test-suite/bugs/closed/2310.v b/test-suite/bugs/closed/2310.v new file mode 100644 index 00000000..0be859ed --- /dev/null +++ b/test-suite/bugs/closed/2310.v @@ -0,0 +1,17 @@ +(* Dependent higher-order hole in "refine" (simplified version) *) + +Set Implicit Arguments. + +Inductive Nest t := Cons : Nest (prod t t) -> Nest t. + +Definition cast A x y Heq P H := @eq_rect A x P H y Heq. + +Definition replace a (y:Nest (prod a a)) : a = a -> Nest a. + +(* This used to raise an anomaly Unknown Meta in 8.2 and 8.3beta. + It raises a regular error in 8.3 and almost succeeds with the new + proof engine: there are two solutions to a unification problem + (P:=\a.Nest (prod a a) and P:=\_.Nest (prod a a)) and refine should either + leave P as subgoal or choose itself one solution *) + +intros. refine (Cons (cast H _ y)). \ No newline at end of file diff --git a/test-suite/bugs/closed/2320.v b/test-suite/bugs/closed/2320.v new file mode 100644 index 00000000..facb9ecf --- /dev/null +++ b/test-suite/bugs/closed/2320.v @@ -0,0 +1,14 @@ +(* Managing metavariables in the return clause of a match *) + +(* This was working in 8.1 but is failing in 8.2 and 8.3. It works in + trunk thanks to the new proof engine. It could probably made to work in + 8.2 and 8.3 if a return predicate of the form "dummy 0" instead of + (or in addition to) a sophisticated predicate of the form + "as x in dummy y return match y with 0 => ?P | _ => ID end" *) + +Inductive dummy : nat -> Prop := constr : dummy 0. + +Lemma failure : forall (x : dummy 0), x = constr. +Proof. +intros x. +refine (match x with constr => _ end). diff --git a/test-suite/bugs/closed/2342.v b/test-suite/bugs/closed/2342.v new file mode 100644 index 00000000..6613b285 --- /dev/null +++ b/test-suite/bugs/closed/2342.v @@ -0,0 +1,8 @@ +(* Checking that the type inference algoithme does not commit to an + equality over sorts when only a subtyping constraint is around *) + +Parameter A : Set. +Parameter B : A -> Set. +Parameter F : Set -> Prop. +Check (F (forall x, B x)). + diff --git a/test-suite/bugs/closed/2347.v b/test-suite/bugs/closed/2347.v new file mode 100644 index 00000000..e433f158 --- /dev/null +++ b/test-suite/bugs/closed/2347.v @@ -0,0 +1,10 @@ +Require Import EquivDec List. +Generalizable All Variables. + +Program Definition list_eqdec `(eqa : EqDec A eq) : EqDec (list A) eq := + (fun (x y : list A) => _). +Admit Obligations of list_eqdec. + +Program Definition list_eqdec' `(eqa : EqDec A eq) : EqDec (list A) eq := + (fun _ : nat => (fun (x y : list A) => _)) 0. +Admit Obligations of list_eqdec'. diff --git a/test-suite/bugs/closed/2350.v b/test-suite/bugs/closed/2350.v new file mode 100644 index 00000000..e91f22e2 --- /dev/null +++ b/test-suite/bugs/closed/2350.v @@ -0,0 +1,6 @@ +(* Check that the fix tactic, when called from refine, reduces enough + to see the products *) + +Definition foo := forall n:nat, n=n. +Definition bar : foo. +refine (fix aux (n:nat) := _). diff --git a/test-suite/bugs/closed/2353.v b/test-suite/bugs/closed/2353.v new file mode 100644 index 00000000..baae9a6e --- /dev/null +++ b/test-suite/bugs/closed/2353.v @@ -0,0 +1,12 @@ +(* Are recursively non-uniform params correctly treated? *) +Inductive list (A:nat -> Type) n := cons : A n -> list A (S n) -> list A n. +Inductive term n := app (l : list term n). +Definition term_list := + fix term_size n (t : term n) (acc : nat) {struct t} : nat := + match t with + | app _ l => + (fix term_list_size n (l : list term n) (acc : nat) {struct l} : nat := + match l with + | cons _ _ t q => term_list_size (S n) q (term_size n t acc) + end) n l (S acc) + end. diff --git a/test-suite/bugs/closed/2360.v b/test-suite/bugs/closed/2360.v new file mode 100644 index 00000000..4ae97c97 --- /dev/null +++ b/test-suite/bugs/closed/2360.v @@ -0,0 +1,13 @@ +(* This failed in V8.3 because descend_in_conjunctions built ill-typed terms *) +Definition interp (etyp : nat -> Type) (p: nat) := etyp p. + +Record Value (etyp : nat -> Type) := Mk { + typ : nat; + value : interp etyp typ +}. + +Definition some_value (etyp : nat -> Type) : (Value etyp). +Proof. + intros. + Fail apply Mk. (* Check that it does not raise an anomaly *) + diff --git a/test-suite/bugs/closed/2362.v b/test-suite/bugs/closed/2362.v new file mode 100644 index 00000000..febb9c7b --- /dev/null +++ b/test-suite/bugs/closed/2362.v @@ -0,0 +1,38 @@ +Set Implicit Arguments. + +Class Pointed (M:Type -> Type) := +{ + creturn: forall {A: Type}, A -> M A +}. + +Unset Implicit Arguments. +Inductive FPair (A B:Type) (neutral: B) : Type:= + fpair : forall (a:A) (b:B), FPair A B neutral. +Implicit Arguments fpair [[A] [B] [neutral]]. + +Set Implicit Arguments. + +Notation "( x ,> y )" := (fpair x y) (at level 0). + +Instance Pointed_FPair B neutral: + Pointed (fun A => FPair A B neutral) := + { creturn := fun A (a:A) => (a,> neutral) }. +Definition blah_fail (x:bool) : FPair bool nat O := + creturn x. +Set Printing All. Print blah_fail. + +Definition blah_explicit (x:bool) : FPair bool nat O := + @creturn _ (Pointed_FPair _ ) _ x. + +Print blah_explicit. + + +Instance Pointed_FPair_mono: + Pointed (fun A => FPair A nat 0) := + { creturn := fun A (a:A) => (a,> 0) }. + + +Definition blah (x:bool) : FPair bool nat O := + creturn x. + + diff --git a/test-suite/bugs/closed/2375.v b/test-suite/bugs/closed/2375.v new file mode 100644 index 00000000..c17c426c --- /dev/null +++ b/test-suite/bugs/closed/2375.v @@ -0,0 +1,18 @@ +(* In the following code, the (superfluous) lemma [lem] is responsible +for the failure of congruence. *) + +Definition f : nat -> Prop := fun x => True. + +Lemma lem : forall x, (True -> True) = ( True -> f x). +Proof. + intros. reflexivity. +Qed. + +Goal forall (x:nat), x = x. +Proof. + intros. + assert (lem := lem). + (*clear ax.*) + congruence. +Qed. + diff --git a/test-suite/bugs/closed/2378.v b/test-suite/bugs/closed/2378.v new file mode 100644 index 00000000..35c69db2 --- /dev/null +++ b/test-suite/bugs/closed/2378.v @@ -0,0 +1,611 @@ +(* test with Coq 8.3rc1 *) + +Require Import Program. + +Inductive Unit: Set := unit: Unit. + +Definition eq_dec T := forall x y:T, {x=y}+{x<>y}. + +Section TTS_TASM. + +Variable Time: Set. +Variable Zero: Time. +Variable tle: Time -> Time -> Prop. +Variable tlt: Time -> Time -> Prop. +Variable tadd: Time -> Time -> Time. +Variable tsub: Time -> Time -> Time. +Variable tmin: Time -> Time -> Time. +Notation "t1 @<= t2" := (tle t1 t2) (at level 70, no associativity). +Notation "t1 @< t2" := (tlt t1 t2) (at level 70, no associativity). +Notation "t1 @+ t2" := (tadd t1 t2) (at level 50, left associativity). +Notation "t1 @- t2" := (tsub t1 t2) (at level 50, left associativity). +Notation "t1 @<= t2 @<= t3" := ((tle t1 t2) /\ (tle t2 t3)) (at level 70, t2 at next level). +Notation "t1 @<= t2 @< t3" := ((tle t1 t2) /\ (tlt t2 t3)) (at level 70, t2 at next level). + +Variable tzerop: forall n, (n = Zero) + {Zero @< n}. +Variable tlt_eq_gt_dec: forall x y, {x @< y} + {x=y} + {y @< x}. +Variable tle_plus_l: forall n m, n @<= n @+ m. +Variable tle_lt_eq_dec: forall n m, n @<= m -> {n @< m} + {n = m}. + +Variable tzerop_zero: tzerop Zero = inleft (Zero @< Zero) (@eq_refl _ Zero). +Variable tplus_n_O: forall n, n @+ Zero = n. +Variable tlt_le_weak: forall n m, n @< m -> n @<= m. +Variable tlt_irrefl: forall n, ~ n @< n. +Variable tplus_nlt: forall n m, ~n @+ m @< n. +Variable tle_n: forall n, n @<= n. +Variable tplus_lt_compat_l: forall n m p, n @< m -> p @+ n @< p @+ m. +Variable tlt_trans: forall n m p, n @< m -> m @< p -> n @< p. +Variable tle_lt_trans: forall n m p, n @<= m -> m @< p -> n @< p. +Variable tlt_le_trans: forall n m p, n @< m -> m @<= p -> n @< p. +Variable tle_refl: forall n, n @<= n. +Variable tplus_le_0: forall n m, n @+ m @<= n -> m = Zero. +Variable Time_eq_dec: eq_dec Time. + +(*************************************************************) + +Section PropLogic. +Variable Predicate: Type. + +Inductive LP: Type := + LPPred: Predicate -> LP +| LPAnd: LP -> LP -> LP +| LPNot: LP -> LP. + +Variable State: Type. +Variable Sat: State -> Predicate -> Prop. + +Fixpoint lpSat st f: Prop := + match f with + LPPred p => Sat st p + | LPAnd f1 f2 => lpSat st f1 /\ lpSat st f2 + | LPNot f1 => ~lpSat st f1 + end. +End PropLogic. + +Implicit Arguments lpSat. + +Fixpoint LPTransfo Pred1 Pred2 p2lp (f: LP Pred1): LP Pred2 := + match f with + LPPred _ p => p2lp p + | LPAnd _ f1 f2 => LPAnd _ (LPTransfo Pred1 Pred2 p2lp f1) (LPTransfo Pred1 Pred2 p2lp f2) + | LPNot _ f1 => LPNot _ (LPTransfo Pred1 Pred2 p2lp f1) + end. +Implicit Arguments LPTransfo. + +Definition addIndex (Ind:Type) (Pred: Ind -> Type) (i: Ind) f := + LPTransfo (fun p => LPPred _ (existT (fun i => Pred i) i p)) f. + +Section TTS. + +Variable State: Type. + +Record TTS: Type := mkTTS { + Init: State -> Prop; + Delay: State -> Time -> State -> Prop; + Next: State -> State -> Prop; + Predicate: Type; + Satisfy: State -> Predicate -> Prop +}. + +Definition TTSIndexedProduct Ind (tts: Ind -> TTS): TTS := mkTTS + (fun st => forall i, Init (tts i) st) + (fun st d st' => forall i, Delay (tts i) st d st') + (fun st st' => forall i, Next (tts i) st st') + { i: Ind & Predicate (tts i) } + (fun st p => Satisfy (tts (projT1 p)) st (projT2 p)). + +End TTS. + +Section SIMU_F. + +Variables StateA StateC: Type. + +Record mapping: Type := mkMapping { + mState: Type; + mInit: StateC -> mState; + mNext: mState -> StateC -> mState; + mDelay: mState -> StateC -> Time -> mState; + mabs: mState -> StateC -> StateA +}. + +Variable m: mapping. + +Record simu (Pred: Type) (a: TTS StateA) (c: TTS StateC) (tra: Pred -> LP (Predicate _ a)) (trc: Pred -> LP (Predicate _ c)): Type := simuPrf { + inv: (mState m) -> StateC -> Prop; + invInit: forall st, Init _ c st -> inv (mInit m st) st; + invDelay: forall ex1 st1 st2 d, Delay _ c st1 d st2 -> inv ex1 st1 -> inv (mDelay m ex1 st1 d) st2; + invNext: forall ex1 st1 st2, Next _ c st1 st2 -> inv ex1 st1 -> inv (mNext m ex1 st1) st2; + simuInit: forall st, Init _ c st -> Init _ a (mabs m (mInit m st) st); + simuDelay: forall ex1 st1 st2 d, Delay _ c st1 d st2 -> inv ex1 st1 -> + Delay _ a (mabs m ex1 st1) d (mabs m (mDelay m ex1 st1 d) st2); + simuNext: forall ex1 st1 st2, Next _ c st1 st2 -> inv ex1 st1 -> + Next _ a (mabs m ex1 st1) (mabs m (mNext m ex1 st1) st2); + simuPred: forall ext st, inv ext st -> + (forall p, lpSat (Satisfy _ c) st (trc p) <-> lpSat (Satisfy _ a) (mabs m ext st) (tra p)) +}. + +Theorem satProd: forall State Ind Pred (Sat: forall i, State -> Pred i -> Prop) (st:State) i (f: LP (Pred i)), + lpSat (Sat i) st f + <-> + lpSat + (fun (st : State) (p : {i : Ind & Pred i}) => Sat (projT1 p) st (projT2 p)) st + (addIndex Ind _ i f). +Proof. + induction f; simpl; intros; split; intros; intuition. +Qed. + +Definition trProd (State: Type) Ind (Pred: Ind -> Type) (tts: Ind -> TTS State) (tr: forall i, (Pred i) -> LP (Predicate _ (tts i))): + {i:Ind & Pred i} -> LP (Predicate _ (TTSIndexedProduct _ Ind tts)) := + fun p => addIndex Ind _ (projS1 p) (tr (projS1 p) (projS2 p)). + +Implicit Arguments trProd. +Require Import Setoid. + +Theorem satTrProd: + forall State Ind Pred (tts: Ind -> TTS State) + (tr: forall i, (Pred i) -> LP (Predicate _ (tts i))) (st:State) (p: {i:Ind & (Pred i)}), + lpSat (Satisfy _ (tts (projS1 p))) st (tr (projS1 p) (projS2 p)) + <-> + lpSat (Satisfy _ (TTSIndexedProduct _ _ tts)) st (trProd _ tts tr p). +Proof. + unfold trProd, TTSIndexedProduct; simpl; intros. + rewrite (satProd State Ind (fun i => Predicate State (tts i)) + (fun i => Satisfy _ (tts i))); tauto. +Qed. + +Theorem simuProd: + forall Ind (Pred: Ind -> Type) (tta: Ind -> TTS StateA) (ttc: Ind -> TTS StateC) + (tra: forall i, (Pred i) -> LP (Predicate _ (tta i))) + (trc: forall i, (Pred i) -> LP (Predicate _ (ttc i))), + (forall i, simu _ (tta i) (ttc i) (tra i) (trc i)) -> + simu _ (TTSIndexedProduct _ Ind tta) (TTSIndexedProduct _ Ind ttc) + (trProd Pred tta tra) (trProd Pred ttc trc). +Proof. + intros. + apply simuPrf with (fun ex st => forall i, inv _ _ (ttc i) (tra i) (trc i) (X i) ex st); simpl; intros; auto. + eapply invInit; eauto. + eapply invDelay; eauto. + eapply invNext; eauto. + eapply simuInit; eauto. + eapply simuDelay; eauto. + eapply simuNext; eauto. + split; simpl; intros. + generalize (proj1 (simuPred _ _ _ _ _ (X (projS1 p)) ext st (H (projS1 p)) (projS2 p))); simpl; intro. + rewrite <- (satTrProd StateA Ind Pred tta tra); apply H1. + rewrite (satTrProd StateC Ind Pred ttc trc); apply H0. + + generalize (proj2 (simuPred _ _ _ _ _ (X (projS1 p)) ext st (H (projS1 p)) (projS2 p))); simpl; intro. + rewrite <- (satTrProd StateC Ind Pred ttc trc); apply H1. + rewrite (satTrProd StateA Ind Pred tta tra); apply H0. +Qed. + +End SIMU_F. + +Section TRANSFO. + +Record simu_equiv StateA StateC m1 m2 Pred (a: TTS StateA) (c: TTS StateC) (tra: Pred -> LP (Predicate _ a)) (trc: Pred -> LP (Predicate _ c)): Type := simuEquivPrf { + simuLR: simu StateA StateC m1 Pred a c tra trc; + simuRL: simu StateC StateA m2 Pred c a trc tra +}. + +Theorem simu_equivProd: + forall StateA StateC m1 m2 Ind (Pred: Ind -> Type) (tta: Ind -> TTS StateA) (ttc: Ind -> TTS StateC) + (tra: forall i, (Pred i) -> LP (Predicate _ (tta i))) + (trc: forall i, (Pred i) -> LP (Predicate _ (ttc i))), + (forall i, simu_equiv StateA StateC m1 m2 _ (tta i) (ttc i) (tra i) (trc i)) -> + simu_equiv StateA StateC m1 m2 _ (TTSIndexedProduct _ Ind tta) (TTSIndexedProduct _ Ind ttc) + (trProd _ _ Pred tta tra) (trProd _ _ Pred ttc trc). +Proof. + intros; split; intros. + apply simuProd; intro. + elim (X i); auto. + apply simuProd; intro. + elim (X i); auto. +Qed. + +Record RTLanguage: Type := mkRTLanguage { + Syntax: Type; + DynamicState: Syntax -> Type; + Semantic: forall (mdl:Syntax), TTS (DynamicState mdl); + MdlPredicate: Syntax -> Type; + MdlPredicateDefinition: forall mdl, MdlPredicate mdl -> LP (Predicate _ (Semantic mdl)) +}. + +Record Transformation (l1 l2: RTLanguage): Type := mkTransformation { + Tmodel: Syntax l1 -> Syntax l2; + Tl1l2: forall mdl, mapping (DynamicState l1 mdl) (DynamicState l2 (Tmodel mdl)); + Tl2l1: forall mdl, mapping (DynamicState l2 (Tmodel mdl)) (DynamicState l1 mdl); + Tpred: forall mdl, MdlPredicate l1 mdl -> LP (MdlPredicate l2 (Tmodel mdl)); + Tsim: forall mdl, simu_equiv (DynamicState l1 mdl) (DynamicState l2 (Tmodel mdl)) (Tl1l2 mdl) (Tl2l1 mdl) + (MdlPredicate l1 mdl) (Semantic l1 mdl) (Semantic l2 (Tmodel mdl)) + (MdlPredicateDefinition l1 mdl) + (fun p => LPTransfo (MdlPredicateDefinition l2 (Tmodel mdl)) (Tpred mdl p)) +}. + +Section Product. + +Record PSyntax (L: RTLanguage): Type := mkPSyntax { + pIndex: Type; + pIsEmpty: pIndex + {pIndex -> False}; + pState: Type; + pComponents: pIndex -> Syntax L; + pIsShared: forall i, DynamicState L (pComponents i) = pState +}. + +Definition pPredicate (L: RTLanguage) (sys: PSyntax L) := { i : pIndex L sys & MdlPredicate L (pComponents L sys i)}. + +(* product with shared state *) + +Definition PLanguage (L: RTLanguage): RTLanguage := + mkRTLanguage + (PSyntax L) + (pState L) + (fun mdl => TTSIndexedProduct (pState L mdl) (pIndex L mdl) + (fun i => match pIsShared L mdl i in (_ = y) return TTS y with + eq_refl => Semantic L (pComponents L mdl i) + end)) + (pPredicate L) + (fun mdl => trProd _ _ _ _ + (fun i pi => match pIsShared L mdl i as e in (_ = y) return + (LP (Predicate y + match e in (_ = y0) return (TTS y0) with + | eq_refl => Semantic L (pComponents L mdl i) + end)) + with + | eq_refl => MdlPredicateDefinition L (pComponents L mdl i) pi + end)). + +Inductive Empty: Type :=. + +Record isSharedTransfo l1 l2 tr: Prop := isSharedTransfoPrf { +sameState: forall mdl i j, + DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) = + DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl j)); +sameMState: forall mdl i j, + mState _ _ (Tl1l2 _ _ tr (pComponents l1 mdl i)) = + mState _ _ (Tl1l2 _ _ tr (pComponents l1 mdl j)); +sameM12: forall mdl i j, + Tl1l2 _ _ tr (pComponents l1 mdl i) = + match sym_eq (sameState mdl i j) in _=y return mapping _ y with + eq_refl => match sym_eq (pIsShared l1 mdl i) in _=x return mapping x _ with + eq_refl => match pIsShared l1 mdl j in _=x return mapping x _ with + eq_refl => Tl1l2 _ _ tr (pComponents l1 mdl j) + end + end + end; +sameM21: forall mdl i j, + Tl2l1 l1 l2 tr (pComponents l1 mdl i) = + match + sym_eq (sameState mdl i j) in (_ = y) + return (mapping y (DynamicState l1 (pComponents l1 mdl i))) + with eq_refl => + match + sym_eq (pIsShared l1 mdl i) in (_ = y) + return + (mapping (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl j))) y) + with + | eq_refl => + match + pIsShared l1 mdl j in (_ = y) + return + (mapping + (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl j))) y) + with + | eq_refl => Tl2l1 l1 l2 tr (pComponents l1 mdl j) + end + end +end +}. + +Definition PTransfoSyntax l1 l2 tr (h: isSharedTransfo l1 l2 tr) mdl := + mkPSyntax l2 (pIndex l1 mdl) + (pIsEmpty l1 mdl) + (match pIsEmpty l1 mdl return Type with + inleft i => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) + |inright h => pState l1 mdl + end) + (fun i => Tmodel l1 l2 tr (pComponents l1 mdl i)) + (fun i => match pIsEmpty l1 mdl as y return + (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) = + match y with + | inleft i0 => + DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i0)) + | inright _ => pState l1 mdl + end) + with + inleft j => sameState l1 l2 tr h mdl i j + | inright h => match h i with end + end). + +Definition compSemantic l mdl i := + match pIsShared l mdl i in (_=y) return TTS y with + eq_refl => Semantic l (pComponents l mdl i) + end. + +Definition compSemanticEq l mdl i s (e: DynamicState l (pComponents l mdl i) = s) := + match e in (_=y) return TTS y with + eq_refl => Semantic l (pComponents l mdl i) + end. + +Definition Pmap12 l1 l2 tr (h: isSharedTransfo l1 l2 tr) (mdl : PSyntax l1) := +match + pIsEmpty l1 mdl as s + return + (mapping (pState l1 mdl) + match s with + | inleft i => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) + | inright _ => pState l1 mdl + end) +with +| inleft p => + match + pIsShared l1 mdl p in (_ = y) + return + (mapping y (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl p)))) + with + | eq_refl => Tl1l2 l1 l2 tr (pComponents l1 mdl p) + end +| inright _ => + mkMapping (pState l1 mdl) (pState l1 mdl) Unit + (fun _ : pState l1 mdl => unit) + (fun (_ : Unit) (_ : pState l1 mdl) => unit) + (fun (_ : Unit) (_ : pState l1 mdl) (_ : Time) => unit) + (fun (_ : Unit) (X : pState l1 mdl) => X) +end. + +Definition Pmap21 l1 l2 tr (h : isSharedTransfo l1 l2 tr) mdl := +match + pIsEmpty l1 mdl as s + return + (mapping + match s with + | inleft i => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) + | inright _ => pState l1 mdl + end (pState l1 mdl)) +with +| inleft p => + match + pIsShared l1 mdl p in (_ = y) + return + (mapping (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl p))) y) + with + | eq_refl => Tl2l1 l1 l2 tr (pComponents l1 mdl p) + end +| inright _ => + mkMapping (pState l1 mdl) (pState l1 mdl) Unit + (fun _ : pState l1 mdl => unit) + (fun (_ : Unit) (_ : pState l1 mdl) => unit) + (fun (_ : Unit) (_ : pState l1 mdl) (_ : Time) => unit) + (fun (_ : Unit) (X : pState l1 mdl) => X) +end. + +Definition PTpred l1 l2 tr (h : isSharedTransfo l1 l2 tr) mdl (pp : pPredicate l1 mdl): + LP (MdlPredicate (PLanguage l2) (PTransfoSyntax l1 l2 tr h mdl)) := +match pIsEmpty l1 mdl with +| inleft _ => + let (x, p) := pp in + addIndex (pIndex l1 mdl) (fun i => MdlPredicate l2 (Tmodel l1 l2 tr (pComponents l1 mdl i))) x + (LPTransfo (Tpred l1 l2 tr (pComponents l1 mdl x)) + (LPPred (MdlPredicate l1 (pComponents l1 mdl x)) p)) +| inright f => match f (projS1 pp) with end +end. + +Lemma simu_eqA: + forall A1 A2 C m P sa sc tta ttc (h: A2=A1), + simu A1 C (match h in (_=y) return mapping _ C with eq_refl => m end) + P (match h in (_=y) return TTS y with eq_refl => sa end) + sc (fun p => match h in (_=y) return LP (Predicate y _) with eq_refl => tta p end) + ttc -> + simu A2 C m P sa sc tta ttc. +admit. +Qed. + +Lemma simu_eqC: + forall A C1 C2 m P sa sc tta ttc (h: C2=C1), + simu A C1 (match h in (_=y) return mapping A _ with eq_refl => m end) + P sa (match h in (_=y) return TTS y with eq_refl => sc end) + tta (fun p => match h in (_=y) return LP (Predicate y _) with eq_refl => ttc p end) + -> + simu A C2 m P sa sc tta ttc. +admit. +Qed. + +Lemma simu_eqA1: + forall A1 A2 C m P sa sc tta ttc (h: A1=A2), + simu A1 C m + P + (match (sym_eq h) in (_=y) return TTS y with eq_refl => sa end) sc + (fun p => match (sym_eq h) as e in (_=y) return LP (Predicate y (match e in (_=z) return TTS z with eq_refl => sa end)) with eq_refl => tta p end) ttc + -> + simu A2 C (match h in (_=y) return mapping _ C with eq_refl => m end) P sa sc tta ttc. +admit. +Qed. + +Lemma simu_eqA2: + forall A1 A2 C m P sa sc tta ttc (h: A1=A2), + simu A1 C (match (sym_eq h) in (_=y) return mapping _ C with eq_refl => m end) + P + sa sc tta ttc + -> + simu A2 C m P + (match h in (_=y) return TTS y with eq_refl => sa end) sc + (fun p => match h as e in (_=y) return LP (Predicate y match e in (_=y0) return TTS y0 with eq_refl => sa end) with eq_refl => tta p end) + ttc. +admit. +Qed. + +Lemma simu_eqC2: + forall A C1 C2 m P sa sc tta ttc (h: C1=C2), + simu A C1 (match (sym_eq h) in (_=y) return mapping A _ with eq_refl => m end) + P + sa sc tta ttc + -> + simu A C2 m P + sa (match h in (_=y) return TTS y with eq_refl => sc end) + tta (fun p => match h as e in (_=y) return LP (Predicate y match e in (_=y0) return TTS y0 with eq_refl => sc end) with eq_refl => ttc p end). +admit. +Qed. + +Lemma simu_eqM: + forall A C m1 m2 P sa sc tta ttc (h: m1=m2), + simu A C m1 P sa sc tta ttc + -> + simu A C m2 P sa sc tta ttc. +admit. +Qed. + +Lemma LPTransfo_trans: + forall Pred1 Pred2 Pred3 (tr1: Pred1 -> LP Pred2) (tr2: Pred2 -> LP Pred3) f, + LPTransfo tr2 (LPTransfo tr1 f) = LPTransfo (fun x => LPTransfo tr2 (tr1 x)) f. +Proof. + admit. +Qed. + +Lemma LPTransfo_addIndex: + forall Ind Pred tr1 x (tr2: forall i, Pred i -> LP (tr1 i)) (p: LP (Pred x)), + addIndex Ind tr1 x (LPTransfo (tr2 x) p) = + LPTransfo + (fun p0 : {i : Ind & Pred i} => + addIndex Ind tr1 (projT1 p0) (tr2 (projT1 p0) (projT2 p0))) + (addIndex Ind Pred x p). +Proof. + unfold addIndex; intros. + rewrite LPTransfo_trans. + rewrite LPTransfo_trans. + simpl. + auto. +Qed. + +Record tr_compat I0 I1 tr := compatPrf { + and_compat: forall p1 p2, tr (LPAnd I0 p1 p2) = LPAnd I1 (tr p1) (tr p2); + not_compat: forall p, tr (LPNot I0 p) = LPNot I1 (tr p) +}. + +Lemma LPTransfo_addIndex_tr: + forall Ind Pred tr0 tr1 x (tr2: forall i, Pred i -> LP (tr0 i)) (tr3: forall i, LP (tr0 i) -> LP (tr1 i)) (p: LP (Pred x)), + (forall x, tr_compat (tr0 x) (tr1 x) (tr3 x)) -> + addIndex Ind tr1 x (tr3 x (LPTransfo (tr2 x) p)) = + LPTransfo + (fun p0 : {i : Ind & Pred i} => + addIndex Ind tr1 (projT1 p0) (tr3 (projT1 p0) (tr2 (projT1 p0) (projT2 p0)))) + (addIndex Ind Pred x p). +Proof. + unfold addIndex; simpl; intros. + rewrite LPTransfo_trans; simpl. + rewrite <- LPTransfo_trans. + f_equal. + induction p; simpl; intros; auto. + rewrite (and_compat _ _ _ (H x)). + rewrite <- IHp1, <- IHp2; auto. + rewrite <- IHp. + rewrite (not_compat _ _ _ (H x)); auto. +Qed. + +Require Export Coq.Logic.FunctionalExtensionality. +Print PLanguage. + +Unset Standard Proposition Elimination Names. + +Program Definition PTransfo l1 l2 (tr: Transformation l1 l2) (h: isSharedTransfo l1 l2 tr): +Transformation (PLanguage l1) (PLanguage l2) := + mkTransformation (PLanguage l1) (PLanguage l2) + (PTransfoSyntax l1 l2 tr h) + (Pmap12 l1 l2 tr h) + (Pmap21 l1 l2 tr h) + (PTpred l1 l2 tr h) + (fun mdl => simu_equivProd + (pState l1 mdl) + (pState l2 (PTransfoSyntax l1 l2 tr h mdl)) + (Pmap12 l1 l2 tr h mdl) + (Pmap21 l1 l2 tr h mdl) + (pIndex l1 mdl) + (fun i => MdlPredicate l1 (pComponents l1 mdl i)) + (compSemantic l1 mdl) + (compSemantic l2 (PTransfoSyntax l1 l2 tr h mdl)) + _ + _ + _ + ). + +Next Obligation. + unfold compSemantic, PTransfoSyntax; simpl. + case (pIsEmpty l1 mdl); simpl; intros. + unfold pPredicate; simpl. + unfold pPredicate in X; simpl in X. + case (sameState l1 l2 tr h mdl i p). + apply (LPTransfo (MdlPredicateDefinition l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)))). + apply (LPTransfo (Tpred l1 l2 tr (pComponents l1 mdl i))). + apply (LPPred _ X). + + apply False_rect; apply (f i). +Defined. + +Next Obligation. + split; intros. + unfold Pmap12; simpl. + unfold PTransfo_obligation_1; simpl. + unfold compSemantic; simpl. + unfold eq_ind, eq_rect, f_equal; simpl. + case (pIsEmpty l1 mdl); intros. + apply simu_eqA2. + apply simu_eqC2. + apply simu_eqM with (Tl1l2 l1 l2 tr (pComponents l1 mdl i)). + apply sameM12. + apply (simuLR _ _ _ _ _ _ _ _ _ (Tsim l1 l2 tr (pComponents l1 mdl i))); intro. + + apply False_rect; apply (f i). + + unfold Pmap21; simpl. + unfold PTransfo_obligation_1; simpl. + unfold compSemantic; simpl. + unfold eq_ind, eq_rect, f_equal; simpl. + case (pIsEmpty l1 mdl); intros. + apply simu_eqC2. + apply simu_eqA2. + apply simu_eqM with (Tl2l1 l1 l2 tr (pComponents l1 mdl i)). + apply sameM21. + apply (simuRL _ _ _ _ _ _ _ _ _ (Tsim l1 l2 tr (pComponents l1 mdl i))); intro. + + apply False_rect; apply (f i). +Qed. + +Next Obligation. + unfold trProd; simpl. + unfold PTransfo_obligation_1; simpl. + unfold compSemantic; simpl. + unfold eq_ind, eq_rect, f_equal; simpl. + apply functional_extensionality; intro. + case x; clear x; intros. + unfold PTpred; simpl. + case (pIsEmpty l1 mdl); simpl; intros. + set (tr0 i := + Predicate (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i))) + (Semantic l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)))). + set (tr1 i := + Predicate (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl p))) + match sameState l1 l2 tr h mdl i p in (_ = y) return (TTS y) with + | eq_refl => Semantic l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) + end). + set (tr2 x := MdlPredicateDefinition l2 (Tmodel l1 l2 tr (pComponents l1 mdl x))). + set (Pred x := MdlPredicate l2 (Tmodel l1 l2 tr (pComponents l1 mdl x))). + set (tr3 x f := match + sameState l1 l2 tr h mdl x p as e in (_ = y) + return + (LP + (Predicate y + match e in (_ = y0) return (TTS y0) with + | eq_refl => Semantic l2 (Tmodel l1 l2 tr (pComponents l1 mdl x)) + end)) + with + | eq_refl => f + end). + apply (LPTransfo_addIndex_tr _ Pred tr0 tr1 x tr2 tr3 + (Tpred l1 l2 tr (pComponents l1 mdl x) m)). + unfold tr0, tr1, tr3; intros; split; simpl; intros; auto. + case (sameState l1 l2 tr h mdl x0 p); auto. + case (sameState l1 l2 tr h mdl x0 p); auto. + + apply False_rect; apply (f x). +Qed. + +End Product. diff --git a/test-suite/bugs/closed/2388.v b/test-suite/bugs/closed/2388.v new file mode 100644 index 00000000..c7926711 --- /dev/null +++ b/test-suite/bugs/closed/2388.v @@ -0,0 +1,10 @@ +(* Error message was not printed in the correct environment *) + +Fail Parameters (A:Prop) (a:A A). + +(* This is a variant (reported as part of bug #2347) *) + +Require Import EquivDec. +Fail Program Instance bool_eq_eqdec : EqDec bool eq := + {equiv_dec x y := (fix aux (x y : bool) {struct x}:= aux _ y) x y}. + diff --git a/test-suite/bugs/closed/2393.v b/test-suite/bugs/closed/2393.v new file mode 100644 index 00000000..fb4f9261 --- /dev/null +++ b/test-suite/bugs/closed/2393.v @@ -0,0 +1,13 @@ +Require Import Program. + +Inductive T := MkT. + +Definition sizeOf (t : T) : nat + := match t with + | MkT => 1 + end. +Variable vect : nat -> Type. +Program Fixpoint idType (t : T) (n := sizeOf t) (b : vect n) {measure n} : T + := match t with + | MkT => MkT + end. diff --git a/test-suite/bugs/closed/2404.v b/test-suite/bugs/closed/2404.v new file mode 100644 index 00000000..8ac696e9 --- /dev/null +++ b/test-suite/bugs/closed/2404.v @@ -0,0 +1,46 @@ +(* Check that dependencies in the indices of the type of the terms to + match are taken into account and correctly generalized *) + +Require Import Relations.Relation_Definitions. +Require Import Basics. + +Record Base := mkBase + {(* Primitives *) + World : Set + (* Names are real, links are theoretical *) + ; Name : World -> Set + + ; wweak : World -> World -> Prop + + ; exportw : forall a b : World, (wweak a b) -> (Name b) -> option (Name a) +}. + +Section Derived. + Variable base : Base. + Definition bWorld := World base. + Definition bName := Name base. + Definition bexportw := exportw base. + Definition bwweak := wweak base. + + Implicit Arguments bexportw [a b]. + +Inductive RstarSetProof {I : Type} (T : I -> I -> Type) : I -> I -> Type := + starReflS : forall a, RstarSetProof T a a +| starTransS : forall i j k, T i j -> (RstarSetProof T j k) -> RstarSetProof T i k. + +Implicit Arguments starTransS [I T i j k]. + +Definition RstarInv {A : Set} (rel : relation A) : A -> A -> Type := (flip (RstarSetProof (flip rel))). + +Definition bwweakFlip (b a : bWorld) : Prop := (bwweak a b). +Definition Rweak : forall a b : bWorld, Type := RstarInv bwweak. + +Fixpoint exportRweak {a b} (aRWb : Rweak a b) (y : bName b) : option (bName a) := + match aRWb,y with + | starReflS _ a, y' => Some y' + | starTransS jWk jRWi, y' => + match (bexportw jWk y) with + | Some x => exportRweak jRWi x + | None => None + end + end. diff --git a/test-suite/bugs/closed/2406.v b/test-suite/bugs/closed/2406.v new file mode 100644 index 00000000..1bd66ffc --- /dev/null +++ b/test-suite/bugs/closed/2406.v @@ -0,0 +1,6 @@ +(* Check correct handling of unsupported notations *) +Notation "'’'" := (fun x => x) (at level 20). + +(* This fails with a syntax error but it is not catched by Fail +Fail Definition crash_the_rooster f := ’. +*) diff --git a/test-suite/bugs/closed/2447.v b/test-suite/bugs/closed/2447.v new file mode 100644 index 00000000..fdeb69fc --- /dev/null +++ b/test-suite/bugs/closed/2447.v @@ -0,0 +1,7 @@ +Record t := {x : bool; y : bool; z : bool}. + +Goal forall x1 x2 y z, + {| x := x1; y := y; z := z |} = {| x := x2; y := y; z := z |} -> x1 = x2. +Proof. +intros; congruence. (* was doing stack overflow *) +Qed. diff --git a/test-suite/bugs/closed/2456.v b/test-suite/bugs/closed/2456.v new file mode 100644 index 00000000..56f046c4 --- /dev/null +++ b/test-suite/bugs/closed/2456.v @@ -0,0 +1,53 @@ + +Require Import Equality. + +Parameter Patch : nat -> nat -> Set. + +Inductive Catch (from to : nat) : Type + := MkCatch : forall (p : Patch from to), + Catch from to. +Implicit Arguments MkCatch [from to]. + +Inductive CatchCommute5 + : forall {from mid1 mid2 to : nat}, + Catch from mid1 + -> Catch mid1 to + -> Catch from mid2 + -> Catch mid2 to + -> Prop + := MkCatchCommute5 : + forall {from mid1 mid2 to : nat} + (p : Patch from mid1) + (q : Patch mid1 to) + (q' : Patch from mid2) + (p' : Patch mid2 to), + CatchCommute5 (MkCatch p) (MkCatch q) (MkCatch q') (MkCatch p'). + +Inductive CatchCommute {from mid1 mid2 to : nat} + (p : Catch from mid1) + (q : Catch mid1 to) + (q' : Catch from mid2) + (p' : Catch mid2 to) + : Prop + := isCatchCommute5 : forall (catchCommuteDetails : CatchCommute5 p q q' p'), + CatchCommute p q q' p'. +Notation "<< p , q >> <~> << q' , p' >>" + := (CatchCommute p q q' p') + (at level 60, no associativity). + +Lemma CatchCommuteUnique2 : + forall {from mid mid' to : nat} + {p : Catch from mid} {q : Catch mid to} + {q' : Catch from mid'} {p' : Catch mid' to} + {q'' : Catch from mid'} {p'' : Catch mid' to} + (commute1 : <> <~> <>) + (commute2 : <> <~> <>), + (p' = p'') /\ (q' = q''). +Proof with auto. +intros. +set (X := commute2). +dependent destruction commute1; +dependent destruction catchCommuteDetails; +dependent destruction commute2; +dependent destruction catchCommuteDetails generalizing X. +Admitted. \ No newline at end of file diff --git a/test-suite/bugs/closed/2464.v b/test-suite/bugs/closed/2464.v new file mode 100644 index 00000000..af708587 --- /dev/null +++ b/test-suite/bugs/closed/2464.v @@ -0,0 +1,39 @@ +Require Import FSetWeakList. +Require Import FSetDecide. + +Parameter Name : Set. +Axiom eq_Name_dec : forall (n : Name) (o : Name), {n = o} + {n <> o}. + +Module DecidableName. +Definition t := Name. +Definition eq := @eq Name. +Definition eq_refl := @refl_equal Name. +Definition eq_sym := @sym_eq Name. +Definition eq_trans := @trans_eq Name. +Definition eq_dec := eq_Name_dec. +End DecidableName. + +Module NameSetMod := Make(DecidableName). + +Module NameSetDec := WDecide (NameSetMod). + +Class PartPatchUniverse (pu_type1 pu_type2 : Type) + : Type := mkPartPatchUniverse { +}. +Class PatchUniverse {pu_type : Type} + (ppu : PartPatchUniverse pu_type pu_type) + : Type := mkPatchUniverse { + pu_nameOf : pu_type -> Name +}. + +Lemma foo : forall (pu_type : Type) + (ppu : PartPatchUniverse pu_type pu_type) + (patchUniverse : PatchUniverse ppu) + (ns ns1 ns2 : NameSetMod.t) + (containsOK : NameSetMod.Equal ns1 ns2) + (p : pu_type) + (HX1 : NameSetMod.Equal ns1 (NameSetMod.add (pu_nameOf p) ns)), + NameSetMod.Equal ns2 (NameSetMod.add (pu_nameOf p) ns). +Proof. +NameSetDec.fsetdec. +Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/2467.v b/test-suite/bugs/closed/2467.v new file mode 100644 index 00000000..ad17814a --- /dev/null +++ b/test-suite/bugs/closed/2467.v @@ -0,0 +1,49 @@ +(* +In the code below, I would expect the + NameSetDec.fsetdec. +to solve the Lemma, but I need to do it in steps instead. + +This is a regression relative to FSet, + +I have v8.3 (13702). +*) + +Require Import Coq.MSets.MSets. + +Parameter Name : Set. +Parameter Name_compare : Name -> Name -> comparison. +Parameter Name_compare_sym : forall {x y : Name}, + Name_compare y x = CompOpp (Name_compare x y). +Parameter Name_compare_trans : forall {c : comparison} + {x y z : Name}, + Name_compare x y = c + -> Name_compare y z = c + -> Name_compare x z = c. +Parameter Name_eq_leibniz : forall {s s' : Name}, + Name_compare s s' = Eq + -> s = s'. + +Module NameOrderedTypeAlt. +Definition t := Name. +Definition compare := Name_compare. +Definition compare_sym := @Name_compare_sym. +Definition compare_trans := @Name_compare_trans. +End NameOrderedTypeAlt. + +Module NameOrderedType := OT_from_Alt(NameOrderedTypeAlt). + +Module NameOrderedTypeWithLeibniz. +Include NameOrderedType. +Definition eq_leibniz := @Name_eq_leibniz. +End NameOrderedTypeWithLeibniz. + +Module NameSetMod := MSetList.MakeWithLeibniz(NameOrderedTypeWithLeibniz). +Module NameSetDec := WDecide (NameSetMod). + +Lemma foo : forall (xs ys : NameSetMod.t) + (n : Name) + (H1 : NameSetMod.Equal xs (NameSetMod.add n ys)), + NameSetMod.In n xs. +Proof. +NameSetDec.fsetdec. +Qed. diff --git a/test-suite/bugs/closed/2473.v b/test-suite/bugs/closed/2473.v new file mode 100644 index 00000000..4c302512 --- /dev/null +++ b/test-suite/bugs/closed/2473.v @@ -0,0 +1,39 @@ + +Require Import Relations Program Setoid Morphisms. + +Section S1. + Variable R: nat -> relation bool. + Instance HR1: forall n, Transitive (R n). Admitted. + Instance HR2: forall n, Symmetric (R n). Admitted. + Hypothesis H: forall n a, R n (andb a a) a. + Goal forall n a b, R n b a. + intros. + (* rewrite <- H. *) (* Anomaly: Evar ?.. was not declared. Please report. *) + (* idem with setoid_rewrite *) +(* assert (HR2' := HR2 n). *) + rewrite <- H. (* ok *) + admit. + Qed. +End S1. + +Section S2. + Variable R: nat -> relation bool. + Instance HR: forall n, Equivalence (R n). Admitted. + Hypothesis H: forall n a, R n (andb a a) a. + Goal forall n a b, R n a b. + intros. rewrite <- H. admit. + Qed. +End S2. + +(* the parametrised relation is required to get the problem *) +Section S3. + Variable R: relation bool. + Instance HR1': Transitive R. Admitted. + Instance HR2': Symmetric R. Admitted. + Hypothesis H: forall a, R (andb a a) a. + Goal forall a b, R b a. + intros. + rewrite <- H. (* ok *) + admit. + Qed. +End S3. \ No newline at end of file diff --git a/test-suite/bugs/closed/2586.v b/test-suite/bugs/closed/2586.v new file mode 100644 index 00000000..7e02e7f1 --- /dev/null +++ b/test-suite/bugs/closed/2586.v @@ -0,0 +1,6 @@ +Require Import Setoid SetoidClass Program. + +Goal forall `(Setoid nat) x y, x == y -> S x == S y. + intros. + Fail clsubst H0. + Abort. \ No newline at end of file diff --git a/test-suite/bugs/closed/2603.v b/test-suite/bugs/closed/2603.v new file mode 100644 index 00000000..371bfdc5 --- /dev/null +++ b/test-suite/bugs/closed/2603.v @@ -0,0 +1,33 @@ +(** Namespace of module vs. namescope of definitions/constructors/... + +As noticed by A. Appel in bug #2603, module names and definition +names used to be in the same namespace. But conflict with names +of constructors (or 2nd mutual inductive...) used to not be checked +enough, leading to stange situations. + +- In 8.3pl3 we introduced checks that forbid uniformly the following + situations. + +- For 8.4 we finally managed to make module names and other names + live in two separate namespace, hence allowing all of the following + situations. +*) + +Module Type T. +End T. + +Declare Module K : T. + +Module Type L. +Declare Module E : T. +End L. + +Module M1 : L with Module E:=K. +Module E := K. +Inductive t := E. (* Used to be accepted, but End M1 below was failing *) +End M1. + +Module M2 : L with Module E:=K. +Inductive t := E. +Module E := K. (* Used to be accepted *) +End M2. (* Used to be accepted *) diff --git a/test-suite/bugs/closed/2608.v b/test-suite/bugs/closed/2608.v new file mode 100644 index 00000000..a4c95ff9 --- /dev/null +++ b/test-suite/bugs/closed/2608.v @@ -0,0 +1,34 @@ + +Module Type T. + Parameter Inline t : Type. +End T. + +Module M. + Definition t := nat. +End M. + +Module Make (X:T). + Include X. + + (* here t is : (Top.Make.t,Top.X.t) *) + + (* in libobject HEAD : EvalConstRef (Top.X.t,Top.X.t) + which is substituted by : {Top.X |-> Top.Make [, Top.Make.t=>Top.X.t]} + which gives : EvalConstRef (Top.Make.t,Top.X.t) *) + +End Make. + +Module P := Make M. + + (* resolver returned by add_module : Top.P.t=>inline *) + (* then constant_of_delta_kn P.t produces (Top.P.t,Top.P.t) *) + + (* in libobject HEAD : EvalConstRef (Top.Make.t,Top.X.t) + given to subst = { |-> Top.M [, Top.M.t=>inline]} + which used to give : EvalConstRef (Top.Make.t,Top.M.t) + given to subst = {Top.Make |-> Top.P [, Top.P.t=>inline]} + which used to give : EvalConstRef (Top.P.t,Top.M.t) *) + +Definition u := P.t. + (* was raising Not_found since Heads.head_map knows of (Top.P.t,Top.M.t) + and not of (Top.P.t,Top.P.t) *) diff --git a/test-suite/bugs/closed/2613.v b/test-suite/bugs/closed/2613.v new file mode 100644 index 00000000..4f0470b1 --- /dev/null +++ b/test-suite/bugs/closed/2613.v @@ -0,0 +1,17 @@ +(* Check that eq_sym is still pointing to Logic.eq_sym after use of Function *) + +Require Import ZArith. +Require Recdef. + +Axiom nat_eq_dec: forall x y : nat, {x=y}+{x<>y}. + +Locate eq_sym. (* Constant Coq.Init.Logic.eq_sym *) + +Function loop (n: nat) {measure (fun x => x) n} : bool := + if nat_eq_dec n 0 then false else loop (pred n). +Proof. + admit. +Defined. + +Check eq_sym eq_refl : 0=0. + diff --git a/test-suite/bugs/closed/2615.v b/test-suite/bugs/closed/2615.v new file mode 100644 index 00000000..dde6a6a5 --- /dev/null +++ b/test-suite/bugs/closed/2615.v @@ -0,0 +1,16 @@ +(* This failed with an anomaly in pre-8.4 because of let-in not + properly taken into account in the test for unification pattern *) + +Inductive foo : forall A, A -> Prop := +| foo_intro : forall A x, foo A x. +Lemma bar A B f : foo (A -> B) f -> forall x : A, foo B (f x). +Fail induction 1. + +(* Whether these examples should succeed with a non-dependent return predicate + or fail because there is well-typed return predicate dependent in f + is questionable. As of 25 oct 2011, they succeed *) +refine (fun p => match p with _ => _ end). +Undo. +refine (fun p => match p with foo_intro _ _ => _ end). +admit. +Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/2616.v b/test-suite/bugs/closed/2616.v new file mode 100644 index 00000000..8758e32d --- /dev/null +++ b/test-suite/bugs/closed/2616.v @@ -0,0 +1,7 @@ +(* Testing ill-typed rewrite which used to succeed in 8.3 *) +Goal + forall (N : nat -> Prop) (g : nat -> sig N) (IN : forall a : sig N, a = g 0), + N 0 -> False. +Proof. +intros. +Fail rewrite IN in H. diff --git a/test-suite/bugs/closed/2629.v b/test-suite/bugs/closed/2629.v new file mode 100644 index 00000000..759cd3dd --- /dev/null +++ b/test-suite/bugs/closed/2629.v @@ -0,0 +1,22 @@ +Class Join (t: Type) : Type := mkJoin {join: t -> t -> t -> Prop}. + +Class sepalg (t: Type) {JOIN: Join t} : Type := + SepAlg { + join_eq: forall {x y z z'}, join x y z -> join x y z' -> z = z'; + join_assoc: forall {a b c d e}, join a b d -> join d c e -> + {f : t & join b c f /\ join a f e}; + join_com: forall {a b c}, join a b c -> join b a c; + join_canc: forall {a1 a2 b c}, join a1 b c -> join a2 b c -> a1=a2; + + unit_for : t -> t -> Prop := fun e a => join e a a; + join_ex_units: forall a, {e : t & unit_for e a} +}. + +Definition joins {A} `{Join A} (a b : A) : Prop := + exists c, join a b c. + +Lemma join_joins {A} `{sepalg A}: forall {a b c}, + join a b c -> joins a b. +Proof. + firstorder. +Qed. diff --git a/test-suite/bugs/closed/2640.v b/test-suite/bugs/closed/2640.v new file mode 100644 index 00000000..da0cc68a --- /dev/null +++ b/test-suite/bugs/closed/2640.v @@ -0,0 +1,17 @@ +(* Testing consistency of globalization and interpretation in some + extreme cases *) + +Section sect. + + (* Simplification of the initial example *) + Hypothesis Other: True. + + Lemma C2 : True. + proof. + Fail have True using Other. + Abort. + + (* Variant of the same problem *) + Lemma C2 : True. + Fail clear; Other. + Abort. diff --git a/test-suite/bugs/closed/2667.v b/test-suite/bugs/closed/2667.v new file mode 100644 index 00000000..0631e535 --- /dev/null +++ b/test-suite/bugs/closed/2667.v @@ -0,0 +1,11 @@ +(* Check that extra arguments to Arguments Scope do not disturb use of *) +(* scopes in constructors *) + +Inductive stmt : Type := Sskip: stmt | Scall : nat -> stmt. +Bind Scope Cminor with stmt. + +(* extra argument is ok because of possible coercion to funclass *) +Arguments Scope Scall [_ Cminor ]. + +(* extra argument is ok because of possible coercion to funclass *) +Fixpoint f (c: stmt) : Prop := match c with Scall _ => False | _ => False end. diff --git a/test-suite/bugs/closed/2668.v b/test-suite/bugs/closed/2668.v new file mode 100644 index 00000000..74c8fa34 --- /dev/null +++ b/test-suite/bugs/closed/2668.v @@ -0,0 +1,6 @@ +Require Import MSetPositive. +Require Import MSetProperties. + +Module Pos := MSetPositive.PositiveSet. +Module PPPP := MSetProperties.WPropertiesOn(Pos). +Print Module PPPP. \ No newline at end of file diff --git a/test-suite/bugs/closed/2670.v b/test-suite/bugs/closed/2670.v new file mode 100644 index 00000000..c401420e --- /dev/null +++ b/test-suite/bugs/closed/2670.v @@ -0,0 +1,21 @@ +(* Check that problems with several solutions are solved in 8.4 as in 8.2 and 8.3 *) + +Inductive Fin: nat -> Set := +| first k : Fin (S k) +| succ k: Fin k -> Fin (S k). + +Lemma match_sym_eq_eq: forall (n1 n2: nat)(f: Fin n1)(e: n1 = n2), +f = match sym_eq e in (_ = l) return (Fin l) with refl_equal => + match e in (_ = l) return (Fin l) with refl_equal => f end end. +Proof. + intros n1 n2 f e. + (* Next line has a dependent and a non dependent solution *) + (* 8.2 and 8.3 used to choose the dependent one which is the one to make *) + (* the goal progress *) + refine (match e return _ with refl_equal => _ end). + reflexivity. + Undo 2. + (* Next line similarly has a dependent and a non dependent solution *) + refine (match e with refl_equal => _ end). + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/2680.v b/test-suite/bugs/closed/2680.v new file mode 100644 index 00000000..0f573a28 --- /dev/null +++ b/test-suite/bugs/closed/2680.v @@ -0,0 +1,17 @@ +(* Tauto bug initially due to wrong test for binary connective *) + +Parameter A B : Type. + +Axiom P : A -> B -> Prop. + +Inductive IP (a : A) (b: B) : Prop := +| IP_def : P a b -> IP a b. + + +Goal forall (a : A) (b : B), IP a b -> ~ IP a b -> False. +Proof. + intros. + tauto. +Qed. + + diff --git a/test-suite/bugs/closed/2713.v b/test-suite/bugs/closed/2713.v new file mode 100644 index 00000000..b5fc74bf --- /dev/null +++ b/test-suite/bugs/closed/2713.v @@ -0,0 +1,17 @@ +Set Implicit Arguments. + +Definition pred_le A (P Q : A->Prop) := + forall x, P x -> Q x. + +Lemma pred_le_refl : forall A (P:A->Prop), + pred_le P P. +Proof. unfold pred_le. auto. Qed. + +Hint Resolve pred_le_refl. + +Lemma test : + forall (P1 P2:nat->Prop), + (forall Q, pred_le (fun a => P1 a /\ P2 a) Q -> True) -> + True. +Proof. intros. eapply H. eauto. (* used to work *) + apply pred_le_refl. Qed. diff --git a/test-suite/bugs/closed/2729.v b/test-suite/bugs/closed/2729.v new file mode 100644 index 00000000..7929b881 --- /dev/null +++ b/test-suite/bugs/closed/2729.v @@ -0,0 +1,115 @@ +(* This bug report actually revealed two bugs in the reconstruction of + a term with "match" in the vm *) + +(* A simplified form of the first problem *) + +(* Reconstruction of terms normalized with vm when a constructor has *) +(* let-ins arguments *) + +Record A : Type := C { a := 0 : nat; b : a=a }. +Goal forall d:A, match d with C a b => b end = match d with C a b => b end. +intro. +vm_compute. +(* Now check that it is well-typed *) +match goal with |- ?c = _ => first [let x := type of c in idtac | fail 2] end. +Abort. + +(* A simplified form of the second problem *) + +Parameter P : nat -> Type. + +Inductive box A := Box : A -> box A. + +Axiom com : {m : nat & box (P m) }. + +Lemma L : + (let (w, s) as com' return (com' = com -> Prop) := com in + let (s0) as s0 + return (existT (fun m : nat => box (P m)) w s0 = com -> Prop) := s in + fun _ : existT (fun m : nat => box (P m)) w (Box (P w) s0) = com => + True) eq_refl. +Proof. +vm_compute. +(* Now check that it is well-typed (the "P w" used to be turned into "P s") *) +match goal with |- ?c => first [let x := type of c in idtac | fail 2] end. +Abort. + +(* Then the original report *) + +Require Import Equality. + +Parameter NameSet : Set. +Parameter SignedName : Set. +Parameter SignedName_compare : forall (x y : SignedName), comparison. +Parameter pu_type : NameSet -> NameSet -> Type. +Parameter pu_nameOf : forall {from to : NameSet}, pu_type from to -> SignedName. +Parameter commute : forall {from mid1 mid2 to : NameSet}, + pu_type from mid1 -> pu_type mid1 to + -> pu_type from mid2 -> pu_type mid2 to -> Prop. + +Program Definition castPatchFrom {from from' to : NameSet} + (HeqFrom : from = from') + (p : pu_type from to) + : pu_type from' to + := p. + +Class PatchUniverse : Type := mkPatchUniverse { + + commutable : forall {from mid1 to : NameSet}, + pu_type from mid1 -> pu_type mid1 to -> Prop + := fun {from mid1 to : NameSet} + (p : pu_type from mid1) (q : pu_type mid1 to) => + exists mid2 : NameSet, + exists q' : pu_type from mid2, + exists p' : pu_type mid2 to, + commute p q q' p'; + + commutable_dec : forall {from mid to : NameSet} + (p : pu_type from mid) + (q : pu_type mid to), + {mid2 : NameSet & + { q' : pu_type from mid2 & + { p' : pu_type mid2 to & + commute p q q' p' }}} + + {~(commutable p q)} +}. + +Inductive SequenceBase (pu : PatchUniverse) + : NameSet -> NameSet -> Type + := Nil : forall {cxt : NameSet}, + SequenceBase pu cxt cxt + | Cons : forall {from mid to : NameSet} + (p : pu_type from mid) + (qs : SequenceBase pu mid to), + SequenceBase pu from to. +Implicit Arguments Nil [pu cxt]. +Implicit Arguments Cons [pu from mid to]. + +Program Fixpoint insertBase {pu : PatchUniverse} + {from mid to : NameSet} + (p : pu_type from mid) + (qs : SequenceBase pu mid to) + : SequenceBase pu from to + := match qs with + | Nil => Cons p Nil + | Cons q qs' => + match SignedName_compare (pu_nameOf p) (pu_nameOf q) with + | Lt => Cons p qs + | _ => match commutable_dec p (castPatchFrom _ q) with + | inleft (existT _ _ (existT _ q' (existT _ p' _))) => Cons q' +(insertBase p' qs') + | inright _ => Cons p qs + end + end + end. + +Lemma insertBaseConsLt {pu : PatchUniverse} + {o op opq opqr : NameSet} + (p : pu_type o op) + (q : pu_type op opq) + (rs : SequenceBase pu opq opqr) + (p_Lt_q : SignedName_compare (pu_nameOf p) (pu_nameOf q) += Lt) + : insertBase p (Cons q rs) = Cons p (Cons q rs). +Proof. +vm_compute. diff --git a/test-suite/bugs/closed/2732.v b/test-suite/bugs/closed/2732.v new file mode 100644 index 00000000..f22a8ccc --- /dev/null +++ b/test-suite/bugs/closed/2732.v @@ -0,0 +1,19 @@ +(* Check correct behavior of add_primitive_tactic in TACEXTEND *) + +(* Added also the case of eauto and congruence *) + +Ltac thus H := solve [H]. + +Lemma test: forall n : nat, n <= n. +Proof. + intro. + thus firstorder. + Undo. + thus eauto. +Qed. + +Lemma test2: false = true -> False. +Proof. + intro. + thus congruence. +Qed. diff --git a/test-suite/bugs/closed/2733.v b/test-suite/bugs/closed/2733.v new file mode 100644 index 00000000..832de4f9 --- /dev/null +++ b/test-suite/bugs/closed/2733.v @@ -0,0 +1,28 @@ +Unset Asymmetric Patterns. + +Definition goodid : forall {A} (x: A), A := fun A x => x. +Definition wrongid : forall A (x: A), A := fun {A} x => x. + +Inductive ty := N | B. + +Inductive alt_list : ty -> ty -> Type := + | nil {k} : alt_list k k + | Ncons {k} : nat -> alt_list B k -> alt_list N k + | Bcons {k} : bool -> alt_list N k -> alt_list B k. + +Definition trullynul k {k'} (l : alt_list k k') := +match k,l with + |N,l' => Ncons 0 (Bcons true l') + |B,l' => Bcons true (Ncons 0 l') +end. + +Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 -> +alt_list t1 t3 := + match l with + | nil => fun _ l2 => P l2 + | Ncons n l1 => fun _ l2 => Ncons n (app (@P) l1 l2) + | Bcons b l1 => fun _ l2 => Bcons b (app (@P) l1 l2) + end. + +Check (fun {t t'} (l: alt_list t t') => + app trullynul (goodid l) (wrongid _ nil)). diff --git a/test-suite/bugs/closed/2734.v b/test-suite/bugs/closed/2734.v new file mode 100644 index 00000000..826361be --- /dev/null +++ b/test-suite/bugs/closed/2734.v @@ -0,0 +1,15 @@ +Require Import Arith List. +Require Import OrderedTypeEx. + +Module Adr. + Include Nat_as_OT. + Definition nat2t (i: nat) : t := i. +End Adr. + +Inductive expr := Const: Adr.t -> expr. + +Inductive control := Go: expr -> control. + +Definition program := (Adr.t * (control))%type. + +Fail Definition myprog : program := (Adr.nat2t 0, Go (Adr.nat2t 0) ). \ No newline at end of file diff --git a/test-suite/bugs/closed/2750.v b/test-suite/bugs/closed/2750.v new file mode 100644 index 00000000..fc580f10 --- /dev/null +++ b/test-suite/bugs/closed/2750.v @@ -0,0 +1,23 @@ + +Module Type ModWithRecord. + + Record foo : Type := + { A : nat + ; B : nat + }. +End ModWithRecord. + +Module Test_ModWithRecord (M : ModWithRecord). + + Definition test1 : M.foo := + {| M.A := 0 + ; M.B := 2 + |}. + + Module B := M. + + Definition test2 : M.foo := + {| M.A := 0 + ; M.B := 2 + |}. +End Test_ModWithRecord. \ No newline at end of file diff --git a/test-suite/bugs/closed/2810.v b/test-suite/bugs/closed/2810.v new file mode 100644 index 00000000..a66078c6 --- /dev/null +++ b/test-suite/bugs/closed/2810.v @@ -0,0 +1,10 @@ +Section foo. + Variable A : Type. + Let B := A. + + Hint Unfold B. + + Goal False. + clear B. autounfold with core. + Abort. +End foo. diff --git a/test-suite/bugs/closed/2817.v b/test-suite/bugs/closed/2817.v new file mode 100644 index 00000000..08dff992 --- /dev/null +++ b/test-suite/bugs/closed/2817.v @@ -0,0 +1,9 @@ +(** Occur-check for Meta (up to application of already known instances) *) + +Goal forall (f: nat -> nat -> Prop) (x:bool) + (H: forall (u: nat), f u u -> True) + (H0: forall x0, f (if x then x0 else x0) x0), +False. + +intros. +Fail apply H in H0. (* should fail without exhausting the stack *) diff --git a/test-suite/bugs/closed/2818.v b/test-suite/bugs/closed/2818.v new file mode 100644 index 00000000..010855cf --- /dev/null +++ b/test-suite/bugs/closed/2818.v @@ -0,0 +1,11 @@ +Module M. + +Local Ltac t := exact I. +Ltac u := t. + +End M. + +Goal True. +Proof. +M.u. +Qed. diff --git a/test-suite/bugs/closed/2828.v b/test-suite/bugs/closed/2828.v new file mode 100644 index 00000000..0b8abace --- /dev/null +++ b/test-suite/bugs/closed/2828.v @@ -0,0 +1,4 @@ +Parameter A B : Type. +Coercion POL (p : prod A B) := fst p. +Goal forall x : prod A B, A. + intro x. Fail exact x. diff --git a/test-suite/bugs/closed/2830.v b/test-suite/bugs/closed/2830.v new file mode 100644 index 00000000..b72c821d --- /dev/null +++ b/test-suite/bugs/closed/2830.v @@ -0,0 +1,226 @@ +(* Bug report #2830 (evar defined twice) covers different bugs *) + +(* 1- This was submitted by qb.h.agws *) + +Module A. + +Set Implicit Arguments. + +Inductive Bit := O | I. + +Inductive BitString: nat -> Set := +| bit: Bit -> BitString 0 +| bitStr: forall n: nat, Bit -> BitString n -> BitString (S n). + +Definition BitOr (a b: Bit) := + match a, b with + | O, O => O + | _, _ => I + end. + +(* Should fail with an error; used to failed in 8.4 and trunk with + anomaly Evd.define: cannot define an evar twice *) + +Fail Fixpoint StringOr (n m: nat) (a: BitString n) (b: BitString m) := + match a with + | bit a' => + match b with + | bit b' => bit (BitOr a' b') + | bitStr b' bT => bitStr b' (StringOr (bit a') bT) + end + | bitStr a' aT => + match b with + | bit b' => bitStr a' (StringOr aT (bit b')) + | bitStr b' bT => bitStr (BitOr a' b') (StringOr aT bT) + end + end. + +End A. + +(* 2- This was submitted by Andrew Appel *) + +Module B. + +Require Import Program Relations. + +Record ageable_facts (A:Type) (level: A -> nat) (age1:A -> option A) := +{ af_unage : forall x x' y', level x' = level y' -> age1 x = Some x' -> exists y, age1 y = Some y' +; af_level1 : forall x, age1 x = None <-> level x = 0 +; af_level2 : forall x y, age1 x = Some y -> level x = S (level y) +}. + +Implicit Arguments af_unage [[A] [level] [age1]]. +Implicit Arguments af_level1 [[A] [level] [age1]]. +Implicit Arguments af_level2 [[A] [level] [age1]]. + +Class ageable (A:Type) := mkAgeable +{ level : A -> nat +; age1 : A -> option A +; age_facts : ageable_facts A level age1 +}. +Definition age {A} `{ageable A} (x y:A) := age1 x = Some y. +Definition necR {A} `{ageable A} : relation A := clos_refl_trans A age. +Delimit Scope pred with pred. +Local Open Scope pred. + +Definition hereditary {A} (R:A->A->Prop) (p:A->Prop) := + forall a a':A, R a a' -> p a -> p a'. + +Definition pred (A:Type) {AG:ageable A} := + { p:A -> Prop | hereditary age p }. + +Bind Scope pred with pred. + +Definition app_pred {A} `{ageable A} (p:pred A) : A -> Prop := proj1_sig p. +Definition pred_hereditary `{ageable} (p:pred A) := proj2_sig p. +Coercion app_pred : pred >-> Funclass. +Global Opaque pred. + +Definition derives {A} `{ageable A} (P Q:pred A) := forall a:A, P a -> Q a. +Implicit Arguments derives. + +Program Definition andp {A} `{ageable A} (P Q:pred A) : pred A := + fun a:A => P a /\ Q a. +Next Obligation. + intros; intro; intuition; apply pred_hereditary with a; auto. +Qed. + +Program Definition imp {A} `{ageable A} (P Q:pred A) : pred A := + fun a:A => forall a':A, necR a a' -> P a' -> Q a'. +Next Obligation. + intros; intro; intuition. + apply H1; auto. + apply rt_trans with a'; auto. + apply rt_step; auto. +Qed. + +Program Definition allp {A} `{ageable A} {B: Type} (f: B -> pred A) : pred A + := fun a => forall b, f b a. +Next Obligation. + intros; intro; intuition. + apply pred_hereditary with a; auto. + apply H1. +Qed. + +Notation "P '<-->' Q" := (andp (imp P Q) (imp Q P)) (at level 57, no associativity) : pred. +Notation "P '|--' Q" := (derives P Q) (at level 80, no associativity). +Notation "'All' x ':' T ',' P " := (allp (fun x:T => P%pred)) (at level 65, x at level 99) : pred. + +Lemma forall_pred_ext {A} `{agA : ageable A}: forall B P Q, + (All x : B, (P x <--> Q x)) |-- (All x : B, P x) <--> (All x: B, Q x). +Abort. + +End B. + +(* 3. *) + +(* This was submitted by Anthony Cowley *) + +Require Import Coq.Classes.Morphisms. +Require Import Setoid. + +Module C. + +Reserved Notation "a ~> b" (at level 70, right associativity). +Reserved Notation "a ≈ b" (at level 54). +Generalizable All Variables. + +Class Category (Object:Type) (Hom:Object -> Object -> Type) := { + hom := Hom where "a ~> b" := (hom a b) : category_scope + ; ob := Object + ; id : forall a, hom a a + ; comp : forall c b a, hom b c -> hom a b -> hom a c + where "g ∘ f" := (comp _ _ _ g f) : category_scope + ; eqv : forall a b, hom a b -> hom a b -> Prop + where "f ≈ g" := (eqv _ _ f g) : category_scope + ; eqv_equivalence : forall a b, Equivalence (eqv a b) + ; comp_respects : forall a b c, + Proper (eqv b c ==> eqv a b ==> eqv a c) (comp c b a) + ; left_identity : forall `(f:a ~> b), id b ∘ f ≈ f + ; right_identity : forall `(f:a ~> b), f ∘ id a ≈ f + ; associativity : forall `(f:a~>b) `(g:b~>c) `(h:c~>d), + h ∘ (g ∘ f) ≈ (h ∘ g) ∘ f +}. +Notation "a ~> b" := (@hom _ _ _ a b) : category_scope. +Notation "g ∘ f" := (@comp _ _ _ _ _ _ g f) : category_scope. +Notation "a ≈ b" := (@eqv _ _ _ _ _ a b) : category_scope. +Notation "a ~{ C }~> b" := (@hom _ _ C a b) (at level 100) : category_scope. +Coercion ob : Category >-> Sortclass. + +Open Scope category_scope. + +Add Parametric Relation `(C:Category Ob Hom) (a b : Ob) : (hom a b) (eqv a b) + reflexivity proved by (@Equivalence_Reflexive _ _ (eqv_equivalence a b)) + symmetry proved by (@Equivalence_Symmetric _ _ (eqv_equivalence a b)) + transitivity proved by (@Equivalence_Transitive _ _ (eqv_equivalence a b)) + as parametric_relation_eqv. + +Add Parametric Morphism `(C:Category Ob Hom) (c b a : Ob) : (comp c b a) + with signature (eqv _ _ ==> eqv _ _ ==> eqv _ _) as parametric_morphism_comp. + intros x y Heq x' y'. apply comp_respects. exact Heq. + Defined. + +Class Functor `(C:Category) `(D:Category) (im : C -> D) := { + functor_im := im + ; fmap : forall {a b}, `(a ~> b) -> im a ~> im b + ; fmap_respects : forall a b (f f' : a ~> b), f ≈ f' -> fmap f ≈ fmap f' + ; fmap_preserves_id : forall a, fmap (id a) ≈ id (im a) + ; fmap_preserves_comp : forall `(f:a~>b) `(g:b~>c), + fmap g ∘ fmap f ≈ fmap (g ∘ f) +}. +Coercion functor_im : Functor >-> Funclass. +Implicit Arguments fmap [Object Hom C Object0 Hom0 D im a b]. + +Add Parametric Morphism `(C:Category) `(D:Category) + (Im:C->D) (F:Functor C D Im) (a b:C) : (@fmap _ _ C _ _ D Im F a b) + with signature (@eqv C _ C a b ==> @eqv D _ D (Im a) (Im b)) + as parametric_morphism_fmap. +intros. apply fmap_respects. assumption. Qed. + +(* HERE IS THE PROBLEMATIC INSTANCE. If we change this to a regular Definition, + then the problem goes away. *) +Instance functor_comp `{C:Category} `{D:Category} `{E:Category} + {Gim} (G:Functor D E Gim) {Fim} (F:Functor C D Fim) + : Functor C E (Basics.compose Gim Fim). +intros. apply Build_Functor with (fmap := fun a b f => fmap G (fmap F f)). +abstract (intros; rewrite H; reflexivity). +abstract (intros; repeat (rewrite fmap_preserves_id); reflexivity). +abstract (intros; repeat (rewrite fmap_preserves_comp); reflexivity). +Defined. + +Definition skel {A:Type} : relation A := @eq A. +Instance skel_equiv A : Equivalence (@skel A). +Admitted. + +Import FunctionalExtensionality. +Instance set_cat : Category Type (fun A B => A -> B) := { + id := fun A => fun x => x + ; comp c b a f g := fun x => f (g x) + ; eqv := fun A B => @skel (A -> B) +}. +intros. compute. symmetry. apply eta_expansion. +intros. compute. symmetry. apply eta_expansion. +intros. compute. reflexivity. Defined. + +(* The [list] type constructor is a Functor. *) + +Import List. + +Definition setList (A:set_cat) := list A. +Instance list_functor : Functor set_cat set_cat setList. +apply Build_Functor with (fmap := @map). +intros. rewrite H. reflexivity. +intros; simpl; apply functional_extensionality. + induction x; [auto|simpl]. rewrite IHx. reflexivity. +intros; simpl; apply functional_extensionality. + induction x; [auto|simpl]. rewrite IHx. reflexivity. +Defined. + +Local Notation "[ a , .. , b ]" := (a :: .. (b :: nil) ..) : list_scope. +Definition setFmap {Fim} {F:Functor set_cat set_cat Fim} `(f:A~>B) (xs:Fim A) := fmap F f xs. + +(* We want to infer the [Functor] instance based on the value's + structure, but the [functor_comp] instance throws things awry. *) +Eval cbv in setFmap (fun x => x * 3) [67,8]. + +End C. diff --git a/test-suite/bugs/closed/2834.v b/test-suite/bugs/closed/2834.v new file mode 100644 index 00000000..6015c53b --- /dev/null +++ b/test-suite/bugs/closed/2834.v @@ -0,0 +1,4 @@ +(* Testing typing of subst *) + +Lemma eqType2Set (a b : Set) (H : @eq Type a b) : @eq Set a b. +Fail subst. diff --git a/test-suite/bugs/closed/2836.v b/test-suite/bugs/closed/2836.v new file mode 100644 index 00000000..a948b75e --- /dev/null +++ b/test-suite/bugs/closed/2836.v @@ -0,0 +1,39 @@ +(* Check that possible instantiation made during evar materialization + are taken into account and do not raise Not_found *) + +Set Implicit Arguments. + +Record SpecializedCategory (obj : Type) (Morphism : obj -> obj -> Type) := { + Object :> _ := obj; + + Identity' : forall o, Morphism o o; + Compose' : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' +}. + +Section SpecializedCategoryInterface. + Variable obj : Type. + Variable mor : obj -> obj -> Type. + Variable C : @SpecializedCategory obj mor. + + Definition Morphism (s d : C) := mor s d. + Definition Identity (o : C) : Morphism o o := C.(Identity') o. + Definition Compose (s d d' : C) (m : Morphism d d') (m0 : Morphism s d) : +Morphism s d' := C.(Compose') s d d' m m0. +End SpecializedCategoryInterface. + +Section ProductCategory. + Variable objC : Type. + Variable morC : objC -> objC -> Type. + Variable objD : Type. + Variable morD : objD -> objD -> Type. + Variable C : SpecializedCategory morC. + Variable D : SpecializedCategory morD. + +(* Should fail nicely *) +Definition ProductCategory : @SpecializedCategory (objC * objD)%type (fun s d +=> (morC (fst s) (fst d) * morD (snd s) (snd d))%type). +Fail refine {| + Identity' := (fun o => (Identity (fst o), Identity (snd o))); + Compose' := (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd +m2) (snd m1))) + |}. diff --git a/test-suite/bugs/closed/2837.v b/test-suite/bugs/closed/2837.v new file mode 100644 index 00000000..5d984463 --- /dev/null +++ b/test-suite/bugs/closed/2837.v @@ -0,0 +1,15 @@ +Require Import JMeq. + +Axiom test : forall n m : nat, JMeq n m. + +Goal forall n m : nat, JMeq n m. + +(* I) with no intros nor variable hints, this should produce a regular error + instead of Uncaught exception Failure("nth"). *) +Fail rewrite test. + +(* II) with intros but indication of variables, still an error *) +Fail (intros; rewrite test). + +(* III) a working variant: *) +intros; rewrite (test n m). \ No newline at end of file diff --git a/test-suite/bugs/closed/2839.v b/test-suite/bugs/closed/2839.v new file mode 100644 index 00000000..e396fe06 --- /dev/null +++ b/test-suite/bugs/closed/2839.v @@ -0,0 +1,10 @@ +(* Check a case where ltac typing error should result in error, not anomaly *) + +Goal forall (H : forall x : nat, x = x), False. +intro. +Fail + let H := + match goal with + | [ H : appcontext G [@eq _ _] |- _ ] => let H' := context G[@plus 2] in H' + end + in pose H. diff --git a/test-suite/bugs/closed/2846.v b/test-suite/bugs/closed/2846.v new file mode 100644 index 00000000..8d6d348a --- /dev/null +++ b/test-suite/bugs/closed/2846.v @@ -0,0 +1,3 @@ +Variable R : Type. + +Fail Inductive I : R := c : R. diff --git a/test-suite/bugs/closed/2848.v b/test-suite/bugs/closed/2848.v new file mode 100644 index 00000000..de137d39 --- /dev/null +++ b/test-suite/bugs/closed/2848.v @@ -0,0 +1,9 @@ +Require Import Setoid. + +Parameter value' : Type. +Parameter equiv' : value' -> value' -> Prop. + +Add Parametric Relation : _ equiv' + reflexivity proved by (Equivalence.equiv_reflexive _) + transitivity proved by (Equivalence.equiv_transitive _) + as apply_equiv'_rel. diff --git a/test-suite/bugs/closed/2850.v b/test-suite/bugs/closed/2850.v new file mode 100644 index 00000000..64a93aeb --- /dev/null +++ b/test-suite/bugs/closed/2850.v @@ -0,0 +1,2 @@ +Definition id {A} (x : A) := x. +Fail Compute id. diff --git a/test-suite/bugs/closed/2854.v b/test-suite/bugs/closed/2854.v new file mode 100644 index 00000000..14aee17f --- /dev/null +++ b/test-suite/bugs/closed/2854.v @@ -0,0 +1,7 @@ +Section foo. + Let foo := Type. + Definition bar : foo -> foo := @id _. + Goal False. + subst foo. + Fail pose bar as f. + (* simpl in f. *) diff --git a/test-suite/bugs/closed/2876.v b/test-suite/bugs/closed/2876.v new file mode 100644 index 00000000..a66ee6b3 --- /dev/null +++ b/test-suite/bugs/closed/2876.v @@ -0,0 +1,11 @@ +Lemma test_bug : forall (R:nat->nat->Prop) n m m' (P: Prop), + P -> + (P -> R n m) -> + (P -> R n m') -> + (forall u, R n u -> u = u -> True) -> + True. +Proof. + intros * HP H1 H2 H3. eapply H3. + eauto. (* H1 is used, but H2 should be used since it is the last hypothesis *) + auto. +Qed. diff --git a/test-suite/bugs/closed/2883.v b/test-suite/bugs/closed/2883.v new file mode 100644 index 00000000..5a5d90a4 --- /dev/null +++ b/test-suite/bugs/closed/2883.v @@ -0,0 +1,34 @@ +Require Import List. +Require Import Coq.Program.Equality. + +Inductive star {genv state : Type} + (step : genv -> state -> state -> Prop) + (ge : genv) : state -> state -> Prop := + | star_refl : forall s : state, star step ge s s + | star_step : + forall (s1 : state) (s2 : state) + (s3 : state), + step ge s1 s2 -> + star step ge s2 s3 -> + star step ge s1 s3. + +Parameter genv expr env mem : Type. +Definition genv' := genv. +Inductive state : Type := + | State : expr -> env -> mem -> state. +Parameter step : genv' -> state -> state -> Prop. + +Section Test. + +Variable ge : genv'. + +Lemma compat_eval_steps: + forall a b e a' b', + star step ge (State a e b) (State a' e b') -> + True. +Proof. + intros. dependent induction H. + trivial. + eapply IHstar; eauto. + replace s2 with (State a' e b') by admit. eauto. +Qed. (* Oups *) diff --git a/test-suite/bugs/closed/2900.v b/test-suite/bugs/closed/2900.v new file mode 100644 index 00000000..8f4264e9 --- /dev/null +++ b/test-suite/bugs/closed/2900.v @@ -0,0 +1,28 @@ +(* Was raising stack overflow in 8.4 and assertion failed in future 8.5 *) +Set Implicit Arguments. + +Require Import List. +Require Import Coq.Program.Equality. + +(** Reflexive-transitive closure ( R* ) *) + +Inductive rtclosure (A : Type) (R : A-> A->Prop) : A->A->Prop := + | rtclosure_refl : forall x, + rtclosure R x x + | rtclosure_step : forall y x z, + R x y -> rtclosure R y z -> rtclosure R x z. + (* bug goes away if rtclosure_step is commented out *) + +(** The closure of the trivial binary relation [eq] *) + +Definition tr (A:Type) := rtclosure (@eq A). + +(** The bug *) + +Lemma bug : forall A B (l t:list A) (r s:list B), + length l = length r -> + tr (combine l r) (combine t s) -> tr l t. +Proof. + intros * E Hp. + (* bug goes away if [revert E] is called explicitly *) + dependent induction Hp. diff --git a/test-suite/bugs/closed/2920.v b/test-suite/bugs/closed/2920.v new file mode 100644 index 00000000..13548b9e --- /dev/null +++ b/test-suite/bugs/closed/2920.v @@ -0,0 +1,2 @@ +Fail Definition my_f_equal {A B : Type} (f : A -> B) (a a' : A) (p : a = a') : f a = f a' := + eq_ind _ _ (fun a' => f a = f a') _ _ p. diff --git a/test-suite/bugs/closed/2923.v b/test-suite/bugs/closed/2923.v new file mode 100644 index 00000000..8a0003a3 --- /dev/null +++ b/test-suite/bugs/closed/2923.v @@ -0,0 +1,12 @@ +Module Type SIGNATURE1. + Inductive IndType: Set := + | AConstructor. +End SIGNATURE1. + +Module Type SIGNATURE2. + Declare Module M1: SIGNATURE1. +End SIGNATURE2. + +Module M2 (Module M1_: SIGNATURE1) : SIGNATURE2. + Module M1 := M1_. +End M2. diff --git a/test-suite/bugs/closed/2928.v b/test-suite/bugs/closed/2928.v new file mode 100644 index 00000000..21e92ae2 --- /dev/null +++ b/test-suite/bugs/closed/2928.v @@ -0,0 +1,11 @@ +Class Equiv A := equiv: A -> A -> Prop. +Infix "=" := equiv : type_scope. + +Class Associative {A} f `{Equiv A} := associativity x y z : f x (f y z) = f (f x y) z. + +Class SemiGroup A op `{Equiv A} := { sg_ass :>> Associative op }. + +Class SemiLattice A op `{Equiv A} := + { semilattice_sg :>> SemiGroup A op + ; redundant : Associative op + }. diff --git a/test-suite/bugs/closed/2930.v b/test-suite/bugs/closed/2930.v new file mode 100644 index 00000000..0994b6fb --- /dev/null +++ b/test-suite/bugs/closed/2930.v @@ -0,0 +1,12 @@ +(* Checking that let-in's hiding evars are expanded when enforcing + "occur-check" *) + +Require Import List. + +Definition foo x y := +let xy := (x, y) in +let bar xys := + match xys with + | nil => xy :: nil + | xy' :: xys' => xy' :: xys' + end in bar (nil : list (nat * nat)). diff --git a/test-suite/bugs/closed/2945.v b/test-suite/bugs/closed/2945.v new file mode 100644 index 00000000..59b57c07 --- /dev/null +++ b/test-suite/bugs/closed/2945.v @@ -0,0 +1,5 @@ +Notation "f1 =1 f2 :> A" := (f1 = (f2 : A)) + (at level 70, f2 at next level, A at level 90) : fun_scope. + +Notation "e :? pf" := (eq_rect _ (fun X : _ => X) e _ pf) + (no associativity, at level 90). diff --git a/test-suite/bugs/closed/2966.v b/test-suite/bugs/closed/2966.v new file mode 100644 index 00000000..debada85 --- /dev/null +++ b/test-suite/bugs/closed/2966.v @@ -0,0 +1,79 @@ +(** Non-termination and state monad with extraction *) +Require Import List. + +Set Implicit Arguments. +Set Asymmetric Patterns. + +Module MemSig. + Definition t: Type := list Type. + + Definition Nth (sig: t) (n: nat) := + nth n sig unit. +End MemSig. + +(** A memory of type [Mem.t s] is the union of cells whose type is specified + by [s]. *) +Module Mem. + Inductive t: MemSig.t -> Type := + | Nil: t nil + | Cons: forall (T: Type), option T -> forall (sig: MemSig.t), t sig -> + t (T :: sig). +End Mem. + +Module Ref. + Inductive t (sig: MemSig.t) (T: Type): Type := + | Input: t sig T. + + Definition Read (sig: MemSig.t) (T: Type) (ref: t sig T) (s: Mem.t sig) + : option T := + match ref with + | Input => None + end. +End Ref. + +Module Monad. + Definition t (sig: MemSig.t) (A: Type) := + Mem.t sig -> option A * Mem.t sig. + + Definition Return (sig: MemSig.t) (A: Type) (x: A): t sig A := + fun s => + (Some x, s). + + Definition Bind (sig: MemSig.t) (A B: Type) (x: t sig A) (f: A -> t sig B) + : t sig B := + fun s => + match x s with + | (Some x', s') => f x' s' + | (None, s') => (None, s') + end. + + Definition Select (T: Type) (f g: unit -> T): T := + f tt. + + (** Read in a reference. *) + Definition Read (sig: MemSig.t) (T: Type) (ref: Ref.t sig T) + : t sig T := + fun s => + match Ref.Read ref s with + | None => (None, s) + | Some x => (Some x, s) + end. +End Monad. + +Import Monad. + +Definition pop (sig: MemSig.t) (T: Type) (trace: Ref.t sig (list T)) + : Monad.t sig T := + Bind (Read trace) (fun _ s => (None, s)). + +Definition sig: MemSig.t := (list nat: Type) :: nil. + +Definition trace: Ref.t sig (list nat). +Admitted. + +Definition Gre (sig: MemSig.t) (trace: _) + (f: bool -> bool): Monad.t sig nat := + Select (fun _ => pop trace) (fun _ => Return 0). + +Definition Arg := + Gre trace (fun _ => false). diff --git a/test-suite/bugs/closed/2969.v b/test-suite/bugs/closed/2969.v new file mode 100644 index 00000000..ff75a1f3 --- /dev/null +++ b/test-suite/bugs/closed/2969.v @@ -0,0 +1,25 @@ +(* Check that Goal.V82.byps and Goal.V82.env are consistent *) + +(* This is a shorten variant of the initial bug which raised anomaly *) + +Goal forall x : nat, (forall z, (exists y:nat, z = y) -> True) -> True. +evar nat. +intros x H. +apply (H n). +unfold n. clear n. +eexists. +reflexivity. +Grab Existential Variables. +admit. + +(* Alternative variant which failed but without raising anomaly *) + +Goal forall x : nat, True. +evar nat. +intro x. +evar nat. +assert (H := eq_refl : n0 = n). +clearbody n n0. +exact I. +Grab Existential Variables. +admit. diff --git a/test-suite/bugs/closed/2981.v b/test-suite/bugs/closed/2981.v new file mode 100644 index 00000000..1facd9b7 --- /dev/null +++ b/test-suite/bugs/closed/2981.v @@ -0,0 +1,15 @@ +Check let TTT := Type in (fun (a b : @sigT TTT (fun A : TTT => A)) + (f : @projT1 TTT (fun A : TTT => A) a -> + @projT1 TTT (fun A : TTT => A) b) => + @eq_refl + (@projT1 TTT (fun A : TTT => A) a -> + @projT1 TTT (fun A : TTT => A) b) + (fun x : @projT1 TTT (fun A : TTT => A) a => f x)) : + forall (a b : @sigT TTT (fun A : TTT => A)) + (f : @projT1 TTT (fun A : TTT => A) a -> + @projT1 TTT (fun A : TTT => A) b), + @eq + (@projT1 TTT (fun A : TTT => A) a -> + @projT1 TTT (fun A : TTT => A) b) + (fun x : @projT1 TTT (fun A : TTT => A) a => f x) f. + diff --git a/test-suite/bugs/closed/2983.v b/test-suite/bugs/closed/2983.v new file mode 100644 index 00000000..15598352 --- /dev/null +++ b/test-suite/bugs/closed/2983.v @@ -0,0 +1,8 @@ +Module Type ModA. +End ModA. +Module Type ModB(A : ModA). +End ModB. +Module Foo(A : ModA)(B : ModB A). +End Foo. + +Print Module Foo. \ No newline at end of file diff --git a/test-suite/bugs/closed/2990.v b/test-suite/bugs/closed/2990.v new file mode 100644 index 00000000..5f832626 --- /dev/null +++ b/test-suite/bugs/closed/2990.v @@ -0,0 +1,8 @@ +Goal True. +Proof. + evar (pfT : Type). + cut pfT. + subst pfT. + intro pf. + refine ((fun A : Set => pf A) unit). +Abort. diff --git a/test-suite/bugs/closed/2994.v b/test-suite/bugs/closed/2994.v new file mode 100644 index 00000000..457b1893 --- /dev/null +++ b/test-suite/bugs/closed/2994.v @@ -0,0 +1,2 @@ +(* Was an anomaly at some time *) +Fail Class foo : Prop := { bar :> Set }. diff --git a/test-suite/bugs/closed/2995.v b/test-suite/bugs/closed/2995.v new file mode 100644 index 00000000..ba3acd08 --- /dev/null +++ b/test-suite/bugs/closed/2995.v @@ -0,0 +1,9 @@ +Module Type Interface. + Parameter error: nat. +End Interface. + +Module Implementation <: Interface. + Definition t := bool. + Definition error: t := false. +Fail End Implementation. +(* A UserError here is expected, not an uncaught Not_found *) \ No newline at end of file diff --git a/test-suite/bugs/closed/2996.v b/test-suite/bugs/closed/2996.v new file mode 100644 index 00000000..440cda61 --- /dev/null +++ b/test-suite/bugs/closed/2996.v @@ -0,0 +1,30 @@ +(* Test on definitions referring to section variables that are not any + longer in the current context *) + +Section x. + + Hypothesis h : forall(n : nat), n < S n. + + Definition f(n m : nat)(less : n < m) : nat := n + m. + + Lemma a : forall(n : nat), f n (S n) (h n) = 1 + 2 * n. + Proof. + (* XXX *) admit. + Qed. + + Lemma b : forall(n : nat), n < 3 + n. + Proof. + clear. + intros n. + Fail assert (H := a n). + Abort. + + Let T := True. + Definition p := I : T. + + Lemma paradox : False. + Proof. + clear. + set (T := False). + Fail pose proof p as H. + Abort. diff --git a/test-suite/bugs/closed/3000.v b/test-suite/bugs/closed/3000.v new file mode 100644 index 00000000..27de34ed --- /dev/null +++ b/test-suite/bugs/closed/3000.v @@ -0,0 +1,2 @@ +Inductive t (t':Type) : Type := A | B. +Definition d := match t with _ => 1 end. (* used to fail on list_chop *) diff --git a/test-suite/bugs/closed/3001.v b/test-suite/bugs/closed/3001.v new file mode 100644 index 00000000..6e565554 --- /dev/null +++ b/test-suite/bugs/closed/3001.v @@ -0,0 +1,21 @@ +Definition my_fun (n:nat) := n. + +Section My_Sec. + Global Arguments my_fun x : rename. +End My_Sec. + +(* The following code suffices to trigger it, on my system: + + Definition my_fun (n:nat) := n. + + Section My_Sec. + Global Arguments my_fun x : rename. + End My_Sec. + +The `Global Arguments` declaration succeeds fine, but the `End My_Sec` fails, with `Anomaly: dirpath_prefix: empty dirpath. Please report.` + +If `Global` is removed, or if no arguments are renamed, then everything works as expected. + +If other declarations go between the `Global Arguments` and the `End My_Sec`, then the other declarations work normally, but the `End My_Sec` still fails. + +Previously reported at https://github.com/HoTT/coq/issues/24 . Occurs in both 8.4 and current trunk. *) diff --git a/test-suite/bugs/closed/3004.v b/test-suite/bugs/closed/3004.v new file mode 100644 index 00000000..896b1958 --- /dev/null +++ b/test-suite/bugs/closed/3004.v @@ -0,0 +1,7 @@ +Set Implicit Arguments. +Unset Strict Implicit. +Parameter (M : nat -> Type). +Parameter (mp : forall (T1 T2 : Type) (f : T1 -> T2), list T1 -> list T2). + +Definition foo (s : list {n : nat & M n}) := + let exT := existT in mp (fun x => projT1 x) s. diff --git a/test-suite/bugs/closed/3008.v b/test-suite/bugs/closed/3008.v new file mode 100644 index 00000000..3f3a979a --- /dev/null +++ b/test-suite/bugs/closed/3008.v @@ -0,0 +1,29 @@ +Module Type Intf1. +Parameter T : Type. +Inductive a := A. +End Intf1. + +Module Impl1 <: Intf1. +Definition T := unit. +Inductive a := A. +End Impl1. + +Module Type Intf2 + (Impl1 : Intf1). +Parameter x : Impl1.A=Impl1.A -> Impl1.T. +End Intf2. + +Module Type Intf3 + (Impl1 : Intf1) + (Impl2 : Intf2(Impl1)). +End Intf3. + +Fail Module Toto + (Impl1' : Intf1) + (Impl2 : Intf2(Impl1')) + (Impl3 : Intf3(Impl1)(Impl2)). +(* A UserError is expected here, not an uncaught Not_found *) + +(* NB : the Inductive above and the A=A weren't in the initial test, + they are here only to force an access to the environment + (cf [Printer.qualid_of_global]) and check that this env is ok. *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3010b.v b/test-suite/bugs/closed/3010b.v new file mode 100644 index 00000000..65fea424 --- /dev/null +++ b/test-suite/bugs/closed/3010b.v @@ -0,0 +1,5 @@ +Definition wtf (n : nat) : nat := + (match n with + 0 => (fun H : n = 0 => 0) + | S n' => (fun H : n = S n' => 0) + end) (eq_refl n). diff --git a/test-suite/bugs/closed/3016.v b/test-suite/bugs/closed/3016.v new file mode 100644 index 00000000..bd4f1dd8 --- /dev/null +++ b/test-suite/bugs/closed/3016.v @@ -0,0 +1,4 @@ +Section foo. + Variable C : Type. + Goal True. + change (eq (A := ?C) ?x ?y) with (eq). diff --git a/test-suite/bugs/closed/3017.v b/test-suite/bugs/closed/3017.v new file mode 100644 index 00000000..63a06bd3 --- /dev/null +++ b/test-suite/bugs/closed/3017.v @@ -0,0 +1,6 @@ +Class A := {}. + Class B {T} `(A) := { B_intro : forall t t' : T, t = t' }. + Lemma foo T (t t' : T) : t = t'. + erewrite @B_intro. + reflexivity. + Abort. diff --git a/test-suite/bugs/closed/3022.v b/test-suite/bugs/closed/3022.v new file mode 100644 index 00000000..dcfe7339 --- /dev/null +++ b/test-suite/bugs/closed/3022.v @@ -0,0 +1,8 @@ +Goal forall (O obj : Type) (f : O -> obj) (x : O) (e : x = x) + (T : obj -> obj -> Type) (m : forall x0 : obj, T x0 x0), + match eq_sym e in (_ = y) return (T (f y) (f x)) with + | eq_refl => m (f x) + end = m (f x). +intros. +try case e. +Abort. diff --git a/test-suite/bugs/closed/3023.v b/test-suite/bugs/closed/3023.v index ed489511..70a1491e 100644 --- a/test-suite/bugs/closed/3023.v +++ b/test-suite/bugs/closed/3023.v @@ -1,5 +1,3 @@ -(* Checking use of eta on Flexible/Rigid and SemiFlexible/Rigid unif problems *) - Set Implicit Arguments. Generalizable All Variables. @@ -14,6 +12,7 @@ Record Category {obj : Type} := Section DiscreteAdjoints. + Let C := {| Morphism := (fun X Y : Type => X -> Y); Identity := (fun X : Type => (fun x : X => x)); @@ -28,4 +27,7 @@ Section DiscreteAdjoints. revert ObjectFunctor. intro ObjectFunctor. simpl in ObjectFunctor. - revert ObjectFunctor. (* Used to failed in 8.4 up to 16 April 2013 *) + revert ObjectFunctor. + Abort. + +End DiscreteAdjoints. diff --git a/test-suite/bugs/closed/3036.v b/test-suite/bugs/closed/3036.v new file mode 100644 index 00000000..451bec9b --- /dev/null +++ b/test-suite/bugs/closed/3036.v @@ -0,0 +1,169 @@ +(* Checking use of retyping in w_unify0 in the presence of unification +problems of the form \x:Meta.Meta = \x:ind.match x with ... end *) + +Require Import List. +Require Import QArith. +Require Import Qcanon. + +Set Implicit Arguments. + +Inductive dynamic : Type := + | Dyn : forall T, T -> dynamic. + +Definition perm := Qc. + +Locate Qle_bool. + +Definition compatibleb (p1 p2 : perm) : bool := +let p1pos := Qle_bool 00 p1 in + let p2pos := Qle_bool 00 p2 in + negb ( + (p1pos && p2pos) + || ((p1pos || p2pos) && (negb (Qle_bool 00 ((p1 + p2)%Qc)))))%Qc. + +Definition compatible (p1 p2 : perm) := compatibleb p1 p2 = true. + +Definition perm_plus (p1 p2 : perm) : option perm := + if compatibleb p1 p2 then Some (p1 + p2) else None. + +Infix "+p" := perm_plus (at level 60, no associativity). + +Axiom axiom_ptr : Set. + +Definition ptr := axiom_ptr. + +Axiom axiom_ptr_eq_dec : forall (a b : ptr), {a = b} + {a <> b}. + +Definition ptr_eq_dec := axiom_ptr_eq_dec. + +Definition hval := (dynamic * perm)%type. + +Definition heap := ptr -> option hval. + +Bind Scope heap_scope with heap. +Delimit Scope heap_scope with heap. +Local Open Scope heap_scope. + +Definition read (h : heap) (p : ptr) : option hval := h p. + +Notation "a # b" := (read a b) (at level 55, no associativity) : heap_scope. + +Definition val (v:hval) := fst v. +Definition frac (v:hval) := snd v. + +Definition hval_plus (v1 v2 : hval) : option hval := + match (frac v1) +p (frac v2) with + | None => None + | Some v1v2 => Some (val v1, v1v2) + end. + +Definition hvalo_plus (v1 v2 : option hval) := + match v1 with + | None => v2 + | Some v1' => + match v2 with + | None => v1 + | Some v2' => (hval_plus v1' v2') + end + end. + +Notation "v1 +o v2" := (hvalo_plus v1 v2) (at level 60, no associativity) : heap_scope. + +Definition join (h1 h2 : heap) : heap := + (fun p => (h1 p) +o (h2 p)). + +Infix "*" := join (at level 40, left associativity) : heap_scope. + +Definition hprop := heap -> Prop. + +Bind Scope hprop_scope with hprop. +Delimit Scope hprop_scope with hprop. + +Definition hprop_cell (p : ptr) T (v : T) (pi:Qc): hprop := fun h => + h#p = Some (Dyn v, pi) /\ forall p', p' <> p -> h#p' = None. + +Notation "p ---> v" := (hprop_cell p v (0%Qc)) (at level 38, no associativity) : hprop_scope. + +Definition empty : heap := fun _ => None. + +Definition hprop_empty : hprop := eq empty. +Notation "'emp'" := hprop_empty : hprop_scope. + +Definition hprop_inj (P : Prop) : hprop := fun h => h = empty /\ P. +Notation "[ P ]" := (hprop_inj P) (at level 0, P at level 200) : hprop_scope. + +Definition hprop_imp (p1 p2 : hprop) : Prop := forall h, p1 h -> p2 h. +Infix "==>" := hprop_imp (right associativity, at level 55). + +Definition hprop_ex T (p : T -> hprop) : hprop := fun h => exists v, p v h. +Notation "'Exists' v :@ T , p" := (hprop_ex (fun v : T => p%hprop)) + (at level 90, T at next level) : hprop_scope. + +Local Open Scope hprop_scope. +Definition disjoint (h1 h2 : heap) : Prop := + forall p, + match h1#p with + | None => True + | Some v1 => match h2#p with + | None => True + | Some v2 => val v1 = val v2 + /\ compatible (frac v1) (frac v2) + end + end. + +Infix "<#>" := disjoint (at level 40, no associativity) : heap_scope. + +Definition split (h h1 h2 : heap) : Prop := h1 <#> h2 /\ h = h1 * h2. + +Notation "h ~> h1 * h2" := (split h h1 h2) (at level 40, h1 at next level, no associativity). + +Definition hprop_sep (p1 p2 : hprop) : hprop := fun h => + exists h1, exists h2, h ~> h1 * h2 + /\ p1 h1 + /\ p2 h2. +Infix "*" := hprop_sep (at level 40, left associativity) : hprop_scope. + +Section Stack. + Variable T : Set. + + Record node : Set := Node { + data : T; + next : option ptr + }. + + Fixpoint listRep (ls : list T) (hd : option ptr) {struct ls} : hprop := + match ls with + | nil => [hd = None] + | h :: t => + match hd with + | None => [False] + | Some hd' => Exists p :@ option ptr, hd' ---> Node h p * listRep t p + end + end%hprop. + + Definition stack := ptr. + + Definition rep q ls := (Exists po :@ option ptr, q ---> po * listRep ls po)%hprop. + + Definition isExistential T (x : T) := True. + + Theorem himp_ex_conc_trivial : forall T p p1 p2, + p ==> p1 * p2 + -> T + -> p ==> hprop_ex (fun _ : T => p1) * p2. + Admitted. + + Goal forall (s : ptr) (x : T) (nd : ptr) (v : unit) (x0 : list T) (v0 : option ptr) + (H0 : isExistential v0), + nd ---> {| data := x; next := v0 |} * (s ---> Some nd * listRep x0 v0) ==> + (Exists po :@ option ptr, + s ---> po * + match po with + | Some hd' => + Exists p :@ option ptr, + hd' ---> {| data := x; next := p |} * listRep x0 p + | None => [False] + end) * emp. + Proof. + intros. + try apply himp_ex_conc_trivial. diff --git a/test-suite/bugs/closed/3037.v b/test-suite/bugs/closed/3037.v new file mode 100644 index 00000000..baa7eff5 --- /dev/null +++ b/test-suite/bugs/closed/3037.v @@ -0,0 +1,11 @@ +(* Anomaly before 4a8950ec7a0d9f2b216e67e69b446c064590a8e9 *) + +Require Import Recdef. + +Function f_R (a: nat) {wf (fun x y: nat => False) a}:Prop:= + match a:nat with + | 0 => True + | (S y') => f_R y' + end. +(* Anomaly: File "plugins/funind/recdef.ml", line 916, characters 13-19: Assertion failed. +Please report. *) diff --git a/test-suite/bugs/closed/3043.v b/test-suite/bugs/closed/3043.v new file mode 100644 index 00000000..654663b4 --- /dev/null +++ b/test-suite/bugs/closed/3043.v @@ -0,0 +1,4 @@ +Goal (fun A (P : A -> Prop) (X : sigT P) => proj1_sig (sig_of_sigT X)) = + (fun A (P : A -> Prop) (X : sigT P) => projT1 X). + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/3045.v b/test-suite/bugs/closed/3045.v new file mode 100644 index 00000000..ef110ad0 --- /dev/null +++ b/test-suite/bugs/closed/3045.v @@ -0,0 +1,34 @@ + +Set Asymmetric Patterns. +Generalizable All Variables. +Set Implicit Arguments. +Set Universe Polymorphism. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Arguments Compose {obj} [C s d d'] m1 m2 : rename. + +Inductive ReifiedMorphism : forall objC (C : SpecializedCategory objC), C -> C -> Type := +| ReifiedComposedMorphism : forall objC C s d d', ReifiedMorphism C d d' -> ReifiedMorphism C s d -> @ReifiedMorphism objC C s d'. + +Fixpoint ReifiedMorphismDenote objC C s d (m : @ReifiedMorphism objC C s d) : Morphism C s d := + match m in @ReifiedMorphism objC C s d return Morphism C s d with + | ReifiedComposedMorphism _ _ _ _ _ m1 m2 => Compose (@ReifiedMorphismDenote _ _ _ _ m1) + (@ReifiedMorphismDenote _ _ _ _ m2) + end. + +Fixpoint ReifiedMorphismSimplifyWithProof objC C s d (m : @ReifiedMorphism objC C s d) +: { m' : ReifiedMorphism C s d | ReifiedMorphismDenote m = ReifiedMorphismDenote m' }. +refine match m with + | ReifiedComposedMorphism _ _ s0 d0 d0' m1 m2 => _ + end; clear m. +(* This fails with an error rather than an anomaly, but morally + it should work, if destruct were able to do the good generalization + in advance, before doing the "intros []". *) +Fail destruct (@ReifiedMorphismSimplifyWithProof T s1 d0 d0' m1) as [ [] ? ]. diff --git a/test-suite/bugs/closed/3050.v b/test-suite/bugs/closed/3050.v new file mode 100644 index 00000000..4b187224 --- /dev/null +++ b/test-suite/bugs/closed/3050.v @@ -0,0 +1,7 @@ +Goal forall A B, A * B -> A. +Proof. +intros A B H. +match goal with + | [ H : _ * _ |- _ ] => exact (fst H) +end. +Qed. diff --git a/test-suite/bugs/closed/3054.v b/test-suite/bugs/closed/3054.v new file mode 100644 index 00000000..936e58e1 --- /dev/null +++ b/test-suite/bugs/closed/3054.v @@ -0,0 +1,10 @@ +Section S. + +Let V := Type. + +Goal ~ true = false. +Proof. +congruence. +Qed. + +End S. diff --git a/test-suite/bugs/closed/3062.v b/test-suite/bugs/closed/3062.v new file mode 100644 index 00000000..a7b5fab0 --- /dev/null +++ b/test-suite/bugs/closed/3062.v @@ -0,0 +1,5 @@ +Lemma foo : forall x y:nat, x < y -> False. +Proof. + intros x y H. + induction H as [ |?y ?y ?y]. +Abort. diff --git a/test-suite/bugs/closed/3068.v b/test-suite/bugs/closed/3068.v new file mode 100644 index 00000000..03e5af61 --- /dev/null +++ b/test-suite/bugs/closed/3068.v @@ -0,0 +1,63 @@ +Section Counted_list. + + Variable A : Type. + + Inductive counted_list : nat -> Type := + | counted_nil : counted_list 0 + | counted_cons : forall(n : nat), + A -> counted_list n -> counted_list (S n). + + + Fixpoint counted_def_nth{n : nat}(l : counted_list n) + (i : nat)(def : A) : A := + match i with + | 0 => match l with + | counted_nil => def + | counted_cons _ a _ => a + end + | S i => match l with + | counted_nil => def + | counted_cons _ _ tl => counted_def_nth tl i def + end + end. + + + Lemma counted_list_equal_nth_char : + forall(n : nat)(l1 l2 : counted_list n)(def : A), + (forall(i : nat), counted_def_nth l1 i def = counted_def_nth l2 i def) -> + l1 = l2. + Proof. + admit. + Qed. + +End Counted_list. + +Implicit Arguments counted_def_nth [A n]. + +Section Finite_nat_set. + + Variable set_size : nat. + + Definition fnat_subset : Type := counted_list bool set_size. + + Definition fnat_member(fs : fnat_subset)(n : nat) : Prop := + is_true (counted_def_nth fs n false). + + + Lemma fnat_subset_member_eq : forall(fs1 fs2 : fnat_subset), + fs1 = fs2 <-> + forall(n : nat), fnat_member fs1 n <-> fnat_member fs2 n. + + Proof. + intros fs1 fs2. + split. + intros H n. + subst fs1. + apply iff_refl. + intros H. + eapply counted_list_equal_nth_char. + intros i. + destruct (counted_def_nth fs1 i _ ) eqn:H0. + (* This was not part of the initial bug report; this is to check that + the existential variable kept its name *) + change (true = counted_def_nth fs2 i ?def). diff --git a/test-suite/bugs/closed/3088.v b/test-suite/bugs/closed/3088.v new file mode 100644 index 00000000..3c362510 --- /dev/null +++ b/test-suite/bugs/closed/3088.v @@ -0,0 +1,12 @@ +Inductive R {A} : A -> A -> Type := c : forall x y, R x y. + +Goal forall A (x y : A) P (e : R x y) (f : forall x y, P x y (c x y)), + let g := match e in R x y return P x y e with c x y => f x y end in + True. +Proof. +intros A x y P e f g. +let t := eval red in g in +match t with + (match ?E as e in R x y return @?P x y e with c X Y => @?f X Y end) => idtac P f +end. +Abort. diff --git a/test-suite/bugs/closed/3093.v b/test-suite/bugs/closed/3093.v new file mode 100644 index 00000000..f6b4a03f --- /dev/null +++ b/test-suite/bugs/closed/3093.v @@ -0,0 +1,6 @@ +Require Import FunctionalExtensionality. + +Goal forall y, @f_equal = y. + intro. + apply functional_extensionality_dep. +Abort. diff --git a/test-suite/bugs/closed/3142.v b/test-suite/bugs/closed/3142.v new file mode 100644 index 00000000..988074e2 --- /dev/null +++ b/test-suite/bugs/closed/3142.v @@ -0,0 +1,9 @@ +(* Fixed together with #3262 in 48af6d1418282323b9fff0e789fed9478c064434 *) +(* April 4, 2014 (non-progress in candidates was not detected) *) + +Definition eqbool_dep (P : bool -> Prop) (h1 : P true) (b : bool) (h2 : P b) + : Prop := +(match b (* return P b -> Prop *) with + | true => fun (h : P true) => h1 = h + | false => fun (_ : P false) => False +end (* : P b -> Prop *)) h2. diff --git a/test-suite/bugs/closed/3164.v b/test-suite/bugs/closed/3164.v new file mode 100644 index 00000000..3c9af8d0 --- /dev/null +++ b/test-suite/bugs/closed/3164.v @@ -0,0 +1,49 @@ +(* Before 31a69c4d0fd7b8325187e8da697a9c283594047d, [case] would stack overflow *) +Require Import Arith. + +Section Acc_generator. + Variable A : Type. + Variable R : A -> A -> Prop. + + (* *Lazily* add 2^n - 1 Acc_intro on top of wf. + Needed for fast reductions using Function and Program Fixpoint + and probably using Fix and Fix_F_2 + *) + Fixpoint Acc_intro_generator n (wf : well_founded R) := + match n with + | O => wf + | S n => fun x => Acc_intro x (fun y _ => Acc_intro_generator n (Acc_intro_generator n wf) y) + end. + + +End Acc_generator. + +Definition pred_F : (forall x : nat, + (forall y : nat, y < x -> (fun _ : nat => nat) y) -> + (fun _ : nat => nat) x). +Proof. + intros x. + simpl. + case x. + exact (fun _ => 0). + intros n h. + apply (h n). + constructor. +Defined. + +Definition my_pred := Fix lt_wf (fun _ => nat) pred_F. + + +Lemma my_pred_is_pred : forall x, match my_pred x with | 0 => True | S n => False end. +Proof. + intros x. + case x. +Abort. + +Definition my_pred_bad := Fix (Acc_intro_generator _ _ 100 lt_wf) (fun _ => nat) pred_F. + +Lemma my_pred_is_pred : forall x, match my_pred_bad x with | 0 => True | S n => False end. +Proof. + intros x. + Timeout 2 case x. +Admitted. diff --git a/test-suite/bugs/closed/3188.v b/test-suite/bugs/closed/3188.v new file mode 100644 index 00000000..01176026 --- /dev/null +++ b/test-suite/bugs/closed/3188.v @@ -0,0 +1,22 @@ +(* File reduced by coq-bug-finder from 1656 lines to 221 lines to 26 lines to 7 lines. *) + +Module Long. + Require Import Coq.Classes.RelationClasses. + + Hint Extern 0 => apply reflexivity : typeclass_instances. + Hint Extern 1 => symmetry. + + Lemma foo : exists m' : Type, True. + intuition. (* Anomaly: Uncaught exception Not_found. Please report. *) + Abort. +End Long. + +Module Short. + Require Import Coq.Classes.RelationClasses. + + Hint Extern 0 => apply reflexivity : typeclass_instances. + + Lemma foo : exists m' : Type, True. + try symmetry. (* Anomaly: Uncaught exception Not_found. Please report. *) + Abort. +End Short. diff --git a/test-suite/bugs/closed/3205.v b/test-suite/bugs/closed/3205.v new file mode 100644 index 00000000..5c44f070 --- /dev/null +++ b/test-suite/bugs/closed/3205.v @@ -0,0 +1,26 @@ +Fail Fixpoint F (u : unit) : Prop := + (fun p : {P : Prop & _} => match p with existT _ _ P => P end) + (existT (fun P => False -> P) (F tt) _). +(* Anomaly: A universe comparison can only happen between variables. +Please report. *) + + + +Definition g (x : Prop) := x. + +Definition h (y : Type) := y. + +Definition eq_hf : h = g :> (Prop -> Type) := + @eq_refl (Prop -> Type) g. + +Set Printing All. +Set Printing Universes. +Fail Definition eq_hf : h = g :> (Prop -> Type) := + eq_refl g. +(* Originally an anomaly, now says +Toplevel input, characters 48-57: +Error: +The term "@eq_refl (forall _ : Prop, Prop) g" has type + "@eq (forall _ : Prop, Prop) g g" while it is expected to have type + "@eq (forall _ : Prop, Type (* Top.16 *)) (fun y : Prop => h y) g" +(Universe inconsistency: Cannot enforce Prop = Top.16)). *) diff --git a/test-suite/bugs/closed/3212.v b/test-suite/bugs/closed/3212.v new file mode 100644 index 00000000..53d8dfe3 --- /dev/null +++ b/test-suite/bugs/closed/3212.v @@ -0,0 +1,10 @@ +Lemma H : Prop = Prop. +reflexivity. +Qed. + +Lemma foo : match H in (_ = X) return X with + | eq_refl => True +end. +Proof. +Fail destruct H. +Abort. diff --git a/test-suite/bugs/closed/3217.v b/test-suite/bugs/closed/3217.v new file mode 100644 index 00000000..ec846bf9 --- /dev/null +++ b/test-suite/bugs/closed/3217.v @@ -0,0 +1,36 @@ +(** [Set Implicit Arguments] causes Coq to run out of memory on [Qed] before c3feef4ed5dec126f1144dec91eee9c0f0522a94 *) +Set Implicit Arguments. + +Variable LEM: forall P : Prop, sumbool P (P -> False). + +Definition pmap := option (nat -> option nat). + +Definition pmplus (oha ohb: pmap) : pmap := + match oha, ohb with + | Some ha, Some hb => + if LEM (oha = ohb) then None else None + | _, _ => None + end. + +Definition pmemp: pmap := Some (fun _ => None). + +Lemma foo: + True -> + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + (pmplus pmemp + pmemp)))))))))))) + = + None -> True. +Proof. + auto. +Timeout 2 Qed. diff --git a/test-suite/bugs/closed/3228.v b/test-suite/bugs/closed/3228.v new file mode 100644 index 00000000..5d1a0ff8 --- /dev/null +++ b/test-suite/bugs/closed/3228.v @@ -0,0 +1,7 @@ +(* Check that variables in the context do not take precedence over + ltac variables *) + +Ltac bar x := exact x. +Goal False -> False. + intro x. + Fail bar doesnotexist. diff --git a/test-suite/bugs/closed/3242.v b/test-suite/bugs/closed/3242.v new file mode 100644 index 00000000..805baee1 --- /dev/null +++ b/test-suite/bugs/closed/3242.v @@ -0,0 +1,2 @@ +Inductive Foo (x := Type) := C : Foo -> Foo. + diff --git a/test-suite/bugs/closed/3251.v b/test-suite/bugs/closed/3251.v new file mode 100644 index 00000000..5a7ae200 --- /dev/null +++ b/test-suite/bugs/closed/3251.v @@ -0,0 +1,13 @@ +Goal True. +Ltac foo := idtac. +(* print out happens twice: +foo is defined +foo is defined + +... that's fishy. But E. Tassi tells me that it's expected since "Ltac" generates a side +effect that escapes the proof. In the STM model this means the command is executed twice, +once in the proof branch, and another time in the main branch *) +Undo. +Ltac foo := idtac. +(* Before 5b39c3535f7b3383d89d7b844537244a4e7c0eca, this would print out: *) +(* Anomaly: Backtrack.backto to a state with no vcs_backup. Please report. *) diff --git a/test-suite/bugs/closed/3258.v b/test-suite/bugs/closed/3258.v new file mode 100644 index 00000000..a1390e30 --- /dev/null +++ b/test-suite/bugs/closed/3258.v @@ -0,0 +1,35 @@ +Require Import Coq.Classes.Morphisms Coq.Classes.RelationClasses Coq.Program.Program Coq.Setoids.Setoid. + +Global Set Implicit Arguments. + +Hint Extern 0 => apply reflexivity : typeclass_instances. + +Inductive Comp : Type -> Type := +| Pick : forall A, (A -> Prop) -> Comp A. + +Axiom computes_to : forall A, Comp A -> A -> Prop. + +Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop. + +Global Instance refine_PreOrder A : PreOrder (@refine A). +Admitted. +Add Parametric Morphism A +: (@Pick A) + with signature + (pointwise_relation _ (flip impl)) + ==> (@refine A) + as refine_flip_impl_Pick. + admit. +Defined. +Definition remove_forall_eq' A x B (P : A -> B -> Prop) : pointwise_relation _ impl (P x) (fun z => forall y : A, y = x -> P y z). + admit. +Defined. +Goal forall A B (x : A) (P : _ -> _ -> Prop), + refine (Pick (fun n : B => forall y, y = x -> P y n)) + (Pick (fun n : B => P x n)). +Proof. + intros. + setoid_rewrite (@remove_forall_eq' _ _ _ _). + Undo. + (* This failed with NotConvertible at some time *) + setoid_rewrite (@remove_forall_eq' _ _ _). diff --git a/test-suite/bugs/closed/3259.v b/test-suite/bugs/closed/3259.v new file mode 100644 index 00000000..0306c686 --- /dev/null +++ b/test-suite/bugs/closed/3259.v @@ -0,0 +1,21 @@ +Goal forall m n, n+n = m+m -> m+m = m+m. +Proof. +intros. +set (k := n+n) in *. +cut (n=m). +intro. +subst n. +admit. +admit. +Qed. + +Goal forall m n, n+n = m+m -> n+n = m+m. +Proof. +intros. +set (k := n+n). +cut (n=m). +intro. +subst n. +admit. +admit. +Qed. diff --git a/test-suite/bugs/closed/3260.v b/test-suite/bugs/closed/3260.v new file mode 100644 index 00000000..9f0231d9 --- /dev/null +++ b/test-suite/bugs/closed/3260.v @@ -0,0 +1,7 @@ +Require Import Setoid. +Goal forall m n, n = m -> n+n = m+m. +intros. +replace n with m at 2. +lazymatch goal with +|- n + m = m + m => idtac +end. diff --git a/test-suite/bugs/closed/3262.v b/test-suite/bugs/closed/3262.v new file mode 100644 index 00000000..70bfde29 --- /dev/null +++ b/test-suite/bugs/closed/3262.v @@ -0,0 +1,78 @@ +(* Not having a [return] clause causes the [refine] at the bottom to stack overflow before f65fa9de8a4c9c12d933188a755b51508bd51921 *) + +Require Import Coq.Lists.List. +Require Import Relations RelationClasses. + +Set Implicit Arguments. +Set Strict Implicit. +Set Asymmetric Patterns. + +Section hlist. + Context {iT : Type}. + Variable F : iT -> Type. + + Inductive hlist : list iT -> Type := + | Hnil : hlist nil + | Hcons : forall l ls, F l -> hlist ls -> hlist (l :: ls). + + Definition hlist_hd {a b} (hl : hlist (a :: b)) : F a := + match hl in hlist x return match x with + | nil => unit + | l :: _ => F l + end with + | Hnil => tt + | Hcons _ _ x _ => x + end. + + Definition hlist_tl {a b} (hl : hlist (a :: b)) : hlist b := + match hl in hlist x return match x with + | nil => unit + | _ :: ls => hlist ls + end with + | Hnil => tt + | Hcons _ _ _ x => x + end. + + Lemma hlist_eta : forall ls (h : hlist ls), + h = match ls as ls return hlist ls -> hlist ls with + | nil => fun _ => Hnil + | a :: b => fun h => Hcons (hlist_hd h) (hlist_tl h) + end h. + Proof. + intros. destruct h; auto. + Qed. + + Variable eqv : forall x, relation (F x). + + Inductive equiv_hlist : forall ls, hlist ls -> hlist ls -> Prop := + | hlist_eqv_nil : equiv_hlist Hnil Hnil + | hlist_eqv_cons : forall l ls x y h1 h2, eqv x y -> equiv_hlist h1 h2 -> + @equiv_hlist (l :: ls) (Hcons x h1) (Hcons y h2). + + Global Instance Reflexive_equiv_hlist (R : forall t, Reflexive (@eqv t)) ls + : Reflexive (@equiv_hlist ls). + Proof. + red. induction x; constructor; auto. reflexivity. + Qed. + + Global Instance Transitive_equiv_hlist (R : forall t, Transitive (@eqv t)) ls + : Transitive (@equiv_hlist ls). + Proof. + red. induction 1. + { intro; assumption. } + { rewrite (hlist_eta z). + Timeout 2 Fail refine + (fun H => + match H in @equiv_hlist ls X Y + return + (* Uncommenting the following gives an immediate error in 8.4pl3; commented out results in a stack overflow *) + match ls (*as ls return hlist ls -> hlist ls -> Type*) with + | nil => fun _ _ : hlist nil => True + | l :: ls => fun (X Y : hlist (l :: ls)) => + equiv_hlist (Hcons x h1) Y + end X Y + with + | hlist_eqv_nil => I + | hlist_eqv_cons l ls x y h1 h2 pf pf' => + _ + end). diff --git a/test-suite/bugs/closed/3264.v b/test-suite/bugs/closed/3264.v new file mode 100644 index 00000000..4eb21890 --- /dev/null +++ b/test-suite/bugs/closed/3264.v @@ -0,0 +1,45 @@ +Module File1. + Module Export DirA. + Module A. + Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + + Arguments idpath {A a} , [A] a. + + Notation "x = y :> A" := (@paths A x y) : type_scope. + Notation "x = y" := (x = y :>_) : type_scope. + End A. + End DirA. +End File1. + +Module File2. + Module Export DirA. + Module B. + Import File1. + Export A. + Lemma foo : forall x y : Type, x = y -> y = x. + Proof. + intros x y H. + rewrite <- H. + constructor. + Qed. + End B. + End DirA. +End File2. + +Module File3. + Module Export DirA. + Module C. + Import File1. + Export A. + Lemma bar : forall x y : Type, x = y -> y = x. + Proof. + intros x y H. + rewrite <- H. + constructor. + Defined. + Definition bar' + := Eval cbv beta iota zeta delta [bar internal_paths_rew] in bar. + End C. + End DirA. +End File3. diff --git a/test-suite/bugs/closed/3265.v b/test-suite/bugs/closed/3265.v new file mode 100644 index 00000000..269c7b74 --- /dev/null +++ b/test-suite/bugs/closed/3265.v @@ -0,0 +1,6 @@ +Require Import Setoid. +Hint Extern 0 => apply reflexivity : typeclass_instances. +Goal forall (B : Type) (P : B -> Prop), exists y : B, P y. + intros. + try reflexivity. (* Anomaly: Uncaught exception Not_found. Please report. *) +Abort. diff --git a/test-suite/bugs/closed/3266.v b/test-suite/bugs/closed/3266.v new file mode 100644 index 00000000..fd4cbff8 --- /dev/null +++ b/test-suite/bugs/closed/3266.v @@ -0,0 +1,3 @@ +Class A := a : nat. +Lemma p : True. +Proof. cut A; [tauto | exact 1]. Qed. diff --git a/test-suite/bugs/closed/3267.v b/test-suite/bugs/closed/3267.v new file mode 100644 index 00000000..5ce1ddf0 --- /dev/null +++ b/test-suite/bugs/closed/3267.v @@ -0,0 +1,36 @@ +Module a. + Local Hint Extern 0 => progress subst. + Goal forall T (x y : T) (P Q : _ -> Prop), x = y -> (P x -> Q x) -> P y -> Q y. + Proof. + intros. + (* this should not fail *) + progress eauto. + Defined. +End a. + +Module b. + Local Hint Extern 0 => progress subst. + Goal forall T (x y : T) (P Q : _ -> Prop), y = x -> (P x -> Q x) -> P y -> Q y. + Proof. + intros. + eauto. + Defined. +End b. + +Module c. + Local Hint Extern 0 => progress subst; eauto. + Goal forall T (x y : T) (P Q : _ -> Prop), x = y -> (P x -> Q x) -> P y -> Q y. + Proof. + intros. + eauto. + Defined. +End c. + +Module d. + Local Hint Extern 0 => progress subst; repeat match goal with H : _ |- _ => revert H end. + Goal forall T (x y : T) (P Q : _ -> Prop), x = y -> (P x -> Q x) -> P y -> Q y. + Proof. + intros. + debug eauto. + Defined. +End d. diff --git a/test-suite/bugs/closed/328.v b/test-suite/bugs/closed/328.v new file mode 100644 index 00000000..52cfbbc4 --- /dev/null +++ b/test-suite/bugs/closed/328.v @@ -0,0 +1,40 @@ +Module Type TITI. +Parameter B:Set. +Parameter x:B. +Inductive A:Set:= +a1:B->A. +Definition f2: A ->B +:= fun (a:A) => +match a with + (a1 b)=>b +end. +Definition f: A -> B:=fun (a:A) => x. +End TITI. + + +Module Type TIT. +Declare Module t:TITI. +End TIT. + +Module Seq(titi:TIT). +Module t:=titi.t. +Inductive toto:t.A->t.B->Set:= +t1:forall (a:t.A), (toto a (t.f a)) +| t2:forall (a:t.A), (toto a (t.f2 a)). +End Seq. + +Module koko(tit:TIT). +Module seq:=Seq tit. +Module t':=tit.t. + +Definition def:forall (a:t'.A), (seq.toto a (t'.f a)). +intro ; constructor 1. +Defined. + +Definition def2: forall (a:t'.A), (seq.toto a (t'.f2 a)). +intro; constructor 2. +(* Toplevel input, characters 0-13 + constructor 2. + ^^^^^^^^^^^^^ +Error: Impossible to unify (seq.toto ?3 (seq.t.f2 ?3)) with + (seq.toto a (t'.f2 a)).*) diff --git a/test-suite/bugs/closed/3281.v b/test-suite/bugs/closed/3281.v new file mode 100644 index 00000000..d340f0ca --- /dev/null +++ b/test-suite/bugs/closed/3281.v @@ -0,0 +1,5 @@ +Fail Lemma foo : @eq _ nat Type. +Fail Lemma foo : @eq Set nat Type. + +Lemma foo : @eq Type nat Type. Admitted. +Lemma foo' : @eq _ Type nat. Admitted. diff --git a/test-suite/bugs/closed/3282.v b/test-suite/bugs/closed/3282.v new file mode 100644 index 00000000..ce7cab1c --- /dev/null +++ b/test-suite/bugs/closed/3282.v @@ -0,0 +1,7 @@ +(* Check let-ins in fix and Fixpoint *) + +Definition foo := fix f (m : nat) (o := true) (n : nat) {struct n} := + match n with 0 => 0 | S n' => f 0 n' end. + +Fixpoint f (m : nat) (o := true) (n : nat) {struct n} := + match n with 0 => 0 | S n' => f 0 n' end. diff --git a/test-suite/bugs/closed/3284.v b/test-suite/bugs/closed/3284.v new file mode 100644 index 00000000..34cd09c6 --- /dev/null +++ b/test-suite/bugs/closed/3284.v @@ -0,0 +1,23 @@ +(* Several bugs: +- wrong env in pose_all_metas_as_evars leading to out of scope instance of evar +- check that metas posed as evars in pose_all_metas_as_evars were + resolved was not done +*) + +Axiom functional_extensionality_dep : + forall {A : Type} {B : A -> Type} (f g : forall x : A, B x), + (forall x : A, f x = g x) -> f = g. + +Goal forall A B C (f g : forall (x : A) (y : B x), C x y), forall x:A, (forall x y, f x y = g x y) -> True. +Proof. + intros A B C f g x H. + Fail apply @functional_extensionality_dep in H. + Fail apply functional_extensionality_dep in H. + eapply functional_extensionality_dep in H. +Abort. + +Goal forall A B C (f g : forall (x : A) (y : B x), C x y), forall x:A, (forall x y, f x y = g x y) -> True. +Proof. + intros A B C f g x H. + specialize (H x). + apply functional_extensionality_dep in H. diff --git a/test-suite/bugs/closed/3285.v b/test-suite/bugs/closed/3285.v new file mode 100644 index 00000000..25162329 --- /dev/null +++ b/test-suite/bugs/closed/3285.v @@ -0,0 +1,7 @@ +Goal True. +Proof. +match goal with + | _ => let x := constr:($(fail)$) in idtac + | _ => idtac +end. +Abort. diff --git a/test-suite/bugs/closed/3286.v b/test-suite/bugs/closed/3286.v new file mode 100644 index 00000000..b08b7ab3 --- /dev/null +++ b/test-suite/bugs/closed/3286.v @@ -0,0 +1,41 @@ +Require Import FunctionalExtensionality. + +Ltac make_apply_under_binders_in lem H := + let tac := make_apply_under_binders_in in + match type of H with + | forall x : ?T, @?P x + => let ret := constr:(fun x' : T => + let Hx := H x' in + $(let ret' := tac lem Hx in + exact ret')$) in + match eval cbv zeta in ret with + | fun x => Some (@?P x) => let P' := (eval cbv zeta in P) in + constr:(Some P') + end + | _ => let ret := constr:($(match goal with + | _ => (let H' := fresh in + pose H as H'; + apply lem in H'; + exact (Some H')) + | _ => exact (@None nat) + end + )$) in + let ret' := (eval cbv beta zeta in ret) in + constr:(ret') + | _ => constr:(@None nat) + end. + +Ltac apply_under_binders_in lem H := + let H' := make_apply_under_binders_in lem H in + let H'0 := match H' with Some ?H'0 => constr:(H'0) end in + let H'' := fresh in + pose proof H'0 as H''; + clear H; + rename H'' into H. + +Goal forall A B C (f g : forall (x : A) (y : B x), C x y), (forall x y, f x y = g x y) -> True. +Proof. + intros A B C f g H. + let lem := constr:(@functional_extensionality_dep) in + apply_under_binders_in lem H. +(* Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/closed/3287.v b/test-suite/bugs/closed/3287.v new file mode 100644 index 00000000..7c781312 --- /dev/null +++ b/test-suite/bugs/closed/3287.v @@ -0,0 +1,20 @@ +Module Foo. +(* Definition foo := (I,I). *) +Definition bar := true. +End Foo. + +Recursive Extraction Foo.bar. + +Module Foo'. +Definition foo := (I,I). +Definition bar := true. +End Foo'. + +Recursive Extraction Foo'.bar. + +Module Foo''. +Definition foo := (I,I). +Definition bar := true. +End Foo''. + +Extraction Foo.bar. diff --git a/test-suite/bugs/closed/3289.v b/test-suite/bugs/closed/3289.v new file mode 100644 index 00000000..4542b015 --- /dev/null +++ b/test-suite/bugs/closed/3289.v @@ -0,0 +1,27 @@ +(* File reduced by coq-bug-finder from original input, then from 1829 lines to 37 lines, then from 47 lines to 18 lines *) + +Class Contr_internal (A : Type) := + BuildContr { center : A ; + contr : (forall y : A, True) }. +Class Contr A := Contr_is_contr : Contr_internal A. +Inductive Unit : Set := tt. +Instance contr_unit : Contr Unit | 0 := + let x := {| + center := tt; + contr := fun t : Unit => I + |} in x. (* success *) + +Instance contr_internal_unit' : Contr_internal Unit | 0 := + {| + center := tt; + contr := fun t : Unit => I + |}. + +Instance contr_unit' : Contr Unit | 0 := + {| + center := tt; + contr := fun t : Unit => I + |}. +(* Error: Mismatched contexts while declaring instance: + Expected: (Contr_is_contr : Contr_internal _UNBOUND_REL_1) + Found: tt (fun t : Unit => I) *) diff --git a/test-suite/bugs/closed/329.v b/test-suite/bugs/closed/329.v new file mode 100644 index 00000000..def6ed98 --- /dev/null +++ b/test-suite/bugs/closed/329.v @@ -0,0 +1,100 @@ +Module Sylvain_Boulme. +Module Type Essai. +Parameter T: Type. +Parameter my_eq: T -> T -> Prop. +Parameter my_eq_refl: forall (x:T), (my_eq x x). +Parameter c: T. +End Essai. + +Module Type Essai2. +Declare Module M: Essai. +Parameter c2: M.T. +End Essai2. + +Module Type Essai3. +Declare Module M: Essai. +Parameter c3: M.T. +End Essai3. + +Module Type Lift. +Declare Module Core: Essai. +Declare Module M: Essai. +Parameter lift: Core.T -> M.T. +Parameter lift_prop:forall (x:Core.T), (Core.my_eq x Core.c)->(M.my_eq (lift x) M.c). +End Lift. + +Module I2 (X:Essai) <: Essai2. + Module Core := X. + Module M<:Essai. + Definition T:Type :=Prop. + Definition my_eq:=(@eq Prop). + Definition c:=True. + Lemma my_eq_refl: forall (x:T), (my_eq x x). + Proof. + unfold my_eq; auto. + Qed. + End M. + Definition c2:=False. + Definition lift:=fun (_:Core.T) => M.c. + Definition lift_prop: forall (x:Core.T), (Core.my_eq x Core.c)->(M.my_eq (lift x) M.c). + Proof. + unfold lift, M.my_eq; auto. + Qed. +End I2. + +Module I4(X:Essai3) (L: Lift with Module Core := X.M) <: Essai3 with Module +M:=L.M. + Module M:=L.M. + Definition c3:=(L.lift X.c3). +End I4. + +Module I5(X:Essai3). + Module Toto<: Lift with Module Core := X.M := I2(X.M). + Module E4<: Essai3 with Module M:=Toto.M := I4(X)(Toto). +(* +Le typage de E4 echoue avec le message + Error: Signature components for label my_eq_refl do not match + *) + + Module E3<: Essai3 := I4(X)(Toto). + + Definition zarb: forall (x:Toto.M.T), (Toto.M.my_eq x x) := E3.M.my_eq_refl. +End I5. +End Sylvain_Boulme. + + +Module Jacek. + + Module Type SIG. + End SIG. + Module N. + Definition A:=Set. + End N. + Module Type SIG2. + Declare Module M:SIG. + Parameter B:Type. + End SIG2. + Module F(X:SIG2 with Module M:=N) (Y:SIG2 with Definition B:=X.M.A). + End F. +End Jacek. + + +Module anoun. + Module Type TITI. + Parameter X: Set. + End TITI. + + Module Type Ex. + Declare Module t: TITI. + Parameter X : t.X -> t.X -> Set. + End Ex. + + Module unionEx(X1: Ex) (X2:Ex with Module t :=X1.t): Ex. + Module t:=X1.t. + Definition X :=fun (a b:t.X) => ((X1.X a b)+(X2.X a b))%type. + End unionEx. +End anoun. +(* Le warning qui s'affiche lors de la compilation est le suivant : + TODO:replace module after with! + Est ce qu'il y'a qq1 qui pourrait m'aider à comprendre le probleme?! + Je vous remercie d'avance *) diff --git a/test-suite/bugs/closed/3291.v b/test-suite/bugs/closed/3291.v new file mode 100644 index 00000000..4ea748c0 --- /dev/null +++ b/test-suite/bugs/closed/3291.v @@ -0,0 +1,9 @@ +Require Import Setoid. + +Definition segv : forall x, (x = 0%nat) -> (forall (y : nat), (y < x)%nat -> nat) = forall (y : nat), (y < 0)%nat -> nat. +intros x eq. +assert (H : forall y, (y < x)%nat = (y < 0)%nat). +rewrite -> eq. auto. +Set Typeclasses Debug. +Fail setoid_rewrite <- H. (* The command has indeed failed with message: +=> Stack overflow. *) diff --git a/test-suite/bugs/closed/3294.v b/test-suite/bugs/closed/3294.v new file mode 100644 index 00000000..ed1a0c29 --- /dev/null +++ b/test-suite/bugs/closed/3294.v @@ -0,0 +1,6 @@ +Check (match true return + match eq_refl Type return Type with eq_refl => bool end + with _ => true end). +Check (match true return + match eq_refl Type with eq_refl => bool end + with _ => true end). diff --git a/test-suite/bugs/closed/3297.v b/test-suite/bugs/closed/3297.v new file mode 100644 index 00000000..1cacb97f --- /dev/null +++ b/test-suite/bugs/closed/3297.v @@ -0,0 +1,12 @@ +Goal forall (n : nat) (H := eq_refl : n = n) (H' : n = 0), H = eq_refl. + intros. + subst. (* Toplevel input, characters 15-20: +Error: Abstracting over the term "n" leads to a term +"λ n : nat, H = eq_refl" which is ill-typed. *) + Undo. + revert H. + subst. (* success *) + Undo. + intro. + clearbody H. + subst. (* success *) diff --git a/test-suite/bugs/closed/3300.v b/test-suite/bugs/closed/3300.v new file mode 100644 index 00000000..a28144b9 --- /dev/null +++ b/test-suite/bugs/closed/3300.v @@ -0,0 +1,7 @@ +Set Primitive Projections. +Record Box (T : Type) : Prop := wrap {prop : T}. + +Definition down (x : Type) : Prop := Box x. +Definition up (x : Prop) : Type := x. + +Fail Definition back A : up (down A) -> A := @prop A. diff --git a/test-suite/bugs/closed/3305.v b/test-suite/bugs/closed/3305.v new file mode 100644 index 00000000..f3f21952 --- /dev/null +++ b/test-suite/bugs/closed/3305.v @@ -0,0 +1,13 @@ +Require Export Coq.Classes.RelationClasses. + +Section defs. + Variable A : Type. + Variable lt : A -> A -> Prop. + Context {ltso : StrictOrder lt}. + + Goal forall (a : A), lt a a -> False. + Proof. + intros a H. + contradict (irreflexivity H). + Qed. +End defs. diff --git a/test-suite/bugs/closed/3306.v b/test-suite/bugs/closed/3306.v new file mode 100644 index 00000000..599e8391 --- /dev/null +++ b/test-suite/bugs/closed/3306.v @@ -0,0 +1,12 @@ + +Inductive Foo(A : Type) : Prop := + foo: A -> Foo A. + +Arguments foo [A] _. + +Scheme Foo_elim := Induction for Foo Sort Prop. + +Goal forall (fn : Foo nat), { x: nat | foo x = fn }. +intro fn. +Fail induction fn as [n] using Foo_elim. (* should fail in a non-Prop context *) +Admitted. diff --git a/test-suite/bugs/closed/3309.v b/test-suite/bugs/closed/3309.v new file mode 100644 index 00000000..fcebdec7 --- /dev/null +++ b/test-suite/bugs/closed/3309.v @@ -0,0 +1,326 @@ +(* -*- coq-prog-args: ("-emacs" "-impredicative-set") -*- *) +(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines *) +Set Universe Polymorphism. +Record sigT' {A} (P : A -> Type) := existT' { projT1' : A; projT2' : P projT1' }. +Notation "{ x : A &' P }" := (sigT' (A := A) (fun x => P)) : type_scope. +Arguments existT' {A} P _ _. +Axiom admit : forall {T}, T. +Notation paths := identity . + +Unset Automatic Introduction. + +Definition UU := Set. + +Definition dirprod ( X Y : UU ) := sigT' ( fun x : X => Y ) . +Definition dirprodpair { X Y : UU } := existT' ( fun x : X => Y ) . + +Definition ddualand { X Y P : UU } (xp : ( X -> P ) -> P ) ( yp : ( Y -> P ) -> P ) : ( dirprod X Y -> P ) -> P. +Proof. + intros X Y P xp yp X0 . + set ( int1 := fun ypp : ( ( Y -> P ) -> P ) => fun x : X => yp ( fun y : Y => X0 ( dirprodpair x y) ) ) . + apply ( xp ( int1 yp ) ) . +Defined . +Definition weq ( X Y : UU ) : UU . +intros; exact ( sigT' (fun f:X->Y => admit) ). +Defined. +Definition pr1weq ( X Y : UU):= @projT1' _ _ : weq X Y -> (X -> Y). +Coercion pr1weq : weq >-> Funclass. + +Definition invweq { X Y : UU } ( w : weq X Y ) : weq Y X . +admit. +Defined. + +Definition hProp := sigT' (fun X : Type => admit). + +Definition hProppair ( X : UU ) ( is : admit ) : hProp@{i j Set k}. +intros; exact (existT' (fun X : UU => admit ) X is ). +Defined. +Definition hProptoType := @projT1' _ _ : hProp -> Type . +Coercion hProptoType: hProp >-> Sortclass. + +Definition ishinh_UU ( X : UU ) : UU := forall P: Set, ( ( X -> P ) -> P ). + +Definition ishinh ( X : UU ) : hProp := hProppair ( ishinh_UU X ) admit. + +Definition hinhfun { X Y : UU } ( f : X -> Y ) : ishinh_UU X -> ishinh_UU Y. +intros X Y f; exact ( fun isx : ishinh X => fun P : _ => fun yp : Y -> P => isx P ( fun x : X => yp ( f x ) ) ). +Defined. + +Definition hinhuniv { X : UU } { P : hProp } ( f : X -> P ) ( wit : ishinh_UU X ) : P. +intros; exact ( wit P f ). +Defined. + +Definition hinhand { X Y : UU } ( inx1 : ishinh_UU X ) ( iny1 : ishinh_UU Y) : ishinh ( dirprod X Y ). +intros; exact ( fun P:_ => ddualand (inx1 P) (iny1 P)) . +Defined. + +Definition UU' := Type. +Definition hSet:= sigT' (fun X : UU' => admit) . +Definition hSetpair := existT' (fun X : UU' => admit). +Definition pr1hSet:= @projT1' UU (fun X : UU' => admit) : hSet -> Type. +Coercion pr1hSet: hSet >-> Sortclass. + +Definition hPropset : hSet := existT' _ hProp admit . + +Definition hsubtypes ( X : UU ) : Type. +intros; exact (X -> hProp ). +Defined. +Definition carrier { X : UU } ( A : hsubtypes X ) : Type. +intros; exact (sigT' A). +Defined. +Coercion carrier : hsubtypes >-> Sortclass. + +Definition subtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : hsubtypes ( dirprod X Y ). +admit. +Defined. + +Lemma weqsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : weq ( subtypesdirprod A B ) ( dirprod A B ) . + admit. +Defined. + +Lemma ishinhsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) ( isa : ishinh A ) ( isb : ishinh B ) : ishinh ( subtypesdirprod A B ) . +Proof . + intros . + apply ( hinhfun ( invweq ( weqsubtypesdirprod A B ) ) ) . + apply hinhand . + apply isa . + apply isb . +Defined . + +Definition hrel ( X : UU ) : Type. +intros; exact ( X -> X -> hProp). +Defined. + +Definition iseqrel { X : UU } ( R : hrel X ) : Type. +admit. +Defined. + +Definition eqrel ( X : UU ) : Type. +intros; exact ( sigT' ( fun R : hrel X => iseqrel R ) ). +Defined. +Definition pr1eqrel ( X : UU ) : eqrel X -> ( X -> ( X -> hProp ) ) := @projT1' _ _ . +Coercion pr1eqrel : eqrel >-> Funclass . + +Definition hreldirprod { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) : hrel ( dirprod X Y ) . +admit. +Defined. +Set Printing Universes. +Print hProp. +Print ishinh_UU. +Print hProppair. +Definition iseqclass { X : UU } ( R : hrel X ) ( A : hsubtypes X ) : Type. +intros; exact ( dirprod ( ishinh ( carrier A ) ) ( dirprod ( forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) )) . +Defined. +Definition iseqclassconstr { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) ) ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) : iseqclass R A. +intros. hnf. apply dirprodpair. exact ax0. apply dirprodpair. exact ax1. exact ax2. +Defined. + +Definition eqax0 { X : UU } { R : hrel X } { A : hsubtypes X } : iseqclass R A -> ishinh ( carrier A ) . +intros X R A; exact ( fun is : iseqclass R A => projT1' _ is ). +Defined. + +Lemma iseqclassdirprod { X Y : UU } { R : hrel X } { Q : hrel Y } { A : hsubtypes X } { B : hsubtypes Y } ( isa : iseqclass R A ) ( isb : iseqclass Q B ) : iseqclass ( hreldirprod R Q ) ( subtypesdirprod A B ) . +Proof . + intros . + set ( XY := dirprod X Y ) . + set ( AB := subtypesdirprod A B ) . + set ( RQ := hreldirprod R Q ) . + set ( ax0 := ishinhsubtypesdirprod A B ( eqax0 isa ) admit ) . + apply ( iseqclassconstr _ ax0 admit admit ) . +Defined . + +Definition image { X Y : UU } ( f : X -> Y ) : Type. +intros; exact ( sigT' ( fun y : Y => admit ) ). +Defined. +Definition pr1image { X Y : UU } ( f : X -> Y ) : image f -> Y. +intros X Y f; exact ( @projT1' _ ( fun y : Y => admit ) ). +Defined. + +Definition prtoimage { X Y : UU } (f : X -> Y) : X -> image f. + admit. +Defined. + +Definition setquot { X : UU } ( R : hrel X ) : Type. +intros; exact ( sigT' ( fun A : _ => iseqclass R A ) ). +Defined. +Definition setquotpair { X : UU } ( R : hrel X ) ( A : hsubtypes X ) ( is : iseqclass R A ) : setquot R. +intros; exact (existT' _ A is ). +Defined. +Definition pr1setquot { X : UU } ( R : hrel X ) : setquot R -> ( hsubtypes X ). +intros X R. +exact ( @projT1' _ ( fun A : _ => iseqclass R A ) ). +Defined. +Coercion pr1setquot : setquot >-> hsubtypes . + +Definition setquotinset { X : UU } ( R : hrel X ) : hSet. +intros; exact ( hSetpair (setquot R) admit) . +Defined. + +Definition dirprodtosetquot { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot RX ) ( setquot RY ) ) : setquot ( hreldirprod RX RY ). +intros; exact ( setquotpair _ _ ( iseqclassdirprod ( projT2' _ ( projT1' _ cd ) ) ( projT2' _ ( projT2' _ cd ) ) ) ). +Defined. + +Definition iscomprelfun2 { X Y : UU } ( R : hrel X ) ( f : X -> X -> Y ) := forall x x' x0 x0' : X , R x x' -> R x0 x0' -> paths ( f x x0 ) ( f x' x0' ) . + +Definition binop ( X : UU ) : Type. +intros; exact ( X -> X -> X ). +Defined. + +Definition setwithbinop : Type. +exact (sigT' ( fun X : hSet => binop X ) ). +Defined. +Definition pr1setwithbinop : setwithbinop -> hSet@{j k Set l}. +unfold setwithbinop. +exact ( @projT1' _ ( fun X : hSet@{j k Set l} => binop@{Set} X ) ). +Defined. +Coercion pr1setwithbinop : setwithbinop >-> hSet . + +Definition op { X : setwithbinop } : binop X. +intros; exact ( projT2' _ X ). +Defined. + +Definition subsetswithbinop { X : setwithbinop } : Type. +admit. +Defined. + +Definition carrierofasubsetwithbinop { X : setwithbinop } ( A : @subsetswithbinop X ) : setwithbinop . +admit. +Defined. + +Coercion carrierofasubsetwithbinop : subsetswithbinop >-> setwithbinop . + +Definition binopeqrel { X : setwithbinop } : Type. +intros; exact (sigT' ( fun R : eqrel X => admit ) ). +Defined. +Definition binopeqrelpair { X : setwithbinop } := existT' ( fun R : eqrel X => admit ). +Definition pr1binopeqrel ( X : setwithbinop ) : @binopeqrel X -> eqrel X. +intros X; exact ( @projT1' _ ( fun R : eqrel X => admit ) ) . +Defined. +Coercion pr1binopeqrel : binopeqrel >-> eqrel . + +Definition setwithbinopdirprod ( X Y : setwithbinop ) : setwithbinop . +admit. +Defined. + +Definition monoid : Type. +exact ( sigT' ( fun X : setwithbinop => admit ) ). +Defined. +Definition monoidpair := existT' ( fun X : setwithbinop => admit ) . +Definition pr1monoid : monoid -> setwithbinop := @projT1' _ _ . +Coercion pr1monoid : monoid >-> setwithbinop . + +Notation "x + y" := ( op x y ) : addmonoid_scope . + +Definition submonoids { X : monoid } : Type. +admit. +Defined. + +Definition submonoidstosubsetswithbinop ( X : monoid ) : @submonoids X -> @subsetswithbinop X. +admit. +Defined. +Coercion submonoidstosubsetswithbinop : submonoids >-> subsetswithbinop . + +Definition abmonoid : Type. +exact (sigT' ( fun X : setwithbinop => admit ) ). +Defined. + +Definition abmonoidtomonoid : abmonoid -> monoid. +exact (fun X : _ => monoidpair ( projT1' _ X ) admit ). +Defined. +Coercion abmonoidtomonoid : abmonoid >-> monoid . + +Definition subabmonoids { X : abmonoid } := @submonoids X . + +Definition carrierofsubabmonoid { X : abmonoid } ( A : @subabmonoids X ) : abmonoid . +Proof . + intros . + unfold subabmonoids in A . + split with A . + admit. +Defined . + +Coercion carrierofsubabmonoid : subabmonoids >-> abmonoid . + +Definition abmonoiddirprod ( X Y : abmonoid ) : abmonoid . +Proof . + intros . + split with ( setwithbinopdirprod X Y ) . + admit. +Defined . + +Open Scope addmonoid_scope . + +Definition eqrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : eqrel ( setwithbinopdirprod X A ). +admit. +Defined. + +Definition binopeqrelabmonoidfrac ( X : abmonoid ) ( A : @subabmonoids X ) : @binopeqrel ( abmonoiddirprod X A ). +intros; exact ( @binopeqrelpair ( setwithbinopdirprod X A ) ( eqrelabmonoidfrac X A ) admit ). +Defined. + +Theorem setquotuniv { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> Y ) ( c : setquot R ) : Y . +Proof. + intros. + apply ( pr1image ( fun x : c => f ( projT1' _ x ) ) ) . + apply ( @hinhuniv ( projT1' _ c ) ( hProppair _ admit ) ( prtoimage ( fun x : c => f ( projT1' _ x ) ) ) ) . + pose ( eqax0 ( projT2' _ c ) ) as h. + simpl in *. + Set Printing Universes. + exact h. +Defined . + +Definition setquotuniv2 { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> X -> Y ) ( is : iscomprelfun2 R f ) ( c c0 : setquot R ) : Y . +Proof. + intros . + set ( RR := hreldirprod R R ) . + apply (setquotuniv RR Y admit). + apply dirprodtosetquot. + apply dirprodpair. + exact c. + exact c0. +Defined . + +Definition setquotfun2 { X Y : UU } ( RX : hrel X ) ( RY : eqrel Y ) ( f : X -> X -> Y ) ( cx cx0 : setquot RX ) : setquot RY . +Proof . + intros . + apply ( setquotuniv2 RX ( setquotinset RY ) admit admit admit admit ) . +Defined . + +Definition quotrel { X : UU } { R : hrel X } : hrel ( setquot R ). +intros; exact ( setquotuniv2 R hPropset admit admit ). +Defined. + +Definition setwithbinopquot { X : setwithbinop } ( R : @binopeqrel X ) : setwithbinop . +Proof . + intros . + split with ( setquotinset R ) . + set ( qtmlt := setquotfun2 R R op ) . + simpl . + unfold binop . + apply qtmlt . +Defined . + +Definition abmonoidquot { X : abmonoid } ( R : @binopeqrel X ) : abmonoid . +Proof . + intros . + split with ( setwithbinopquot R ) . + admit. +Defined . + +Definition abmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : abmonoid. +intros; exact ( @abmonoidquot (abmonoiddirprod X (@carrierofsubabmonoid X A)) ( binopeqrelabmonoidfrac X A ) ). +Defined. + +Definition abmonoidfracrel ( X : abmonoid ) ( A : @submonoids X ) : hrel (@setquot (setwithbinopdirprod X A) (eqrelabmonoidfrac X A)). +intros; exact (@quotrel _ _). +Defined. + +Fail Timeout 1 Axiom ispartlbinopabmonoidfracrel : forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ) , @abmonoidfracrel X A ( ( admit + z ) )admit. + +Definition ispartlbinopabmonoidfracrel_type : Type := + forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ), + @abmonoidfracrel X A ( ( admit + z ) )admit. + +Axiom ispartlbinopabmonoidfracrel : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in + ispartlbinopabmonoidfracrel_type in exact t)$. + diff --git a/test-suite/bugs/closed/331.v b/test-suite/bugs/closed/331.v new file mode 100644 index 00000000..9ef796fa --- /dev/null +++ b/test-suite/bugs/closed/331.v @@ -0,0 +1,20 @@ +Module Type TIT. + +Inductive X:Set:= + b:X. +End TIT. + + +Module Type TOTO. +Declare Module t:TIT. +Inductive titi:Set:= + a:t.X->titi. +End TOTO. + + +Module toto (ta:TOTO). +Module ti:=ta.t. + +Definition ex1:forall (c d:ti.X), (ta.a d)=(ta.a c) -> d=c. +intros. +injection H. diff --git a/test-suite/bugs/closed/3310.v b/test-suite/bugs/closed/3310.v new file mode 100644 index 00000000..d6c31c6b --- /dev/null +++ b/test-suite/bugs/closed/3310.v @@ -0,0 +1,11 @@ +Set Primitive Projections. +Set Implicit Arguments. + +CoInductive stream A := cons { hd : A; tl : stream A }. + +CoFixpoint id {A} (s : stream A) := cons (hd s) (id (tl s)). + +Lemma id_spec : forall A (s : stream A), id s = s. +Proof. +intros A s. +Fail change (id s) with (cons (hd (id s)) (tl (id s))). diff --git a/test-suite/bugs/closed/3314.v b/test-suite/bugs/closed/3314.v new file mode 100644 index 00000000..64786263 --- /dev/null +++ b/test-suite/bugs/closed/3314.v @@ -0,0 +1,147 @@ +Set Universe Polymorphism. +Definition Lift +: $(let U1 := constr:(Type) in + let U0 := constr:(Type : U1) in + exact (U0 -> U1))$ + := fun T => T. + +Fail Check nat:Prop. (* The command has indeed failed with message: +=> Error: +The term "nat" has type "Set" while it is expected to have type "Prop". *) +Set Printing All. +Set Printing Universes. +Fail Check Lift nat : Prop. (* Lift (* Top.8 Top.9 Top.10 *) nat:Prop + : Prop +(* Top.10 + Top.9 + Top.8 |= Top.10 < Top.9 + Top.9 < Top.8 + Top.9 <= Prop + *) + *) +Fail Eval compute in Lift nat : Prop. +(* = nat + : Prop *) + +Section Hurkens. + + Monomorphic Definition Type2 := Type. + Monomorphic Definition Type1 := Type : Type2. + + (** Assumption of a retract from Type into Prop *) + + Variable down : Type1 -> Prop. + Variable up : Prop -> Type1. + + Hypothesis back : forall A, up (down A) -> A. + + Hypothesis forth : forall A, A -> up (down A). + + Hypothesis backforth : forall (A:Type) (P:A->Type) (a:A), + P (back A (forth A a)) -> P a. + + Hypothesis backforth_r : forall (A:Type) (P:A->Type) (a:A), + P a -> P (back A (forth A a)). + + (** Proof *) + + Definition V : Type1 := forall A:Prop, ((up A -> Prop) -> up A -> Prop) -> up A -> Prop. + Definition U : Type1 := V -> Prop. + + Definition sb (z:V) : V := fun A r a => r (z A r) a. + Definition le (i:U -> Prop) (x:U) : Prop := x (fun A r a => i (fun v => sb v A r a)). + Definition le' (i:up (down U) -> Prop) (x:up (down U)) : Prop := le (fun a:U => i (forth _ a)) (back _ x). + Definition induct (i:U -> Prop) : Type1 := forall x:U, up (le i x) -> up (i x). + Definition WF : U := fun z => down (induct (fun a => z (down U) le' (forth _ a))). + Definition I (x:U) : Prop := + (forall i:U -> Prop, up (le i x) -> up (i (fun v => sb v (down U) le' (forth _ x)))) -> False. + + Lemma Omega : forall i:U -> Prop, induct i -> up (i WF). + Proof. + intros i y. + apply y. + unfold le, WF, induct. + apply forth. + intros x H0. + apply y. + unfold sb, le', le. + compute. + apply backforth_r. + exact H0. + Qed. + + Lemma lemma1 : induct (fun u => down (I u)). + Proof. + unfold induct. + intros x p. + apply forth. + intro q. + generalize (q (fun u => down (I u)) p). + intro r. + apply back in r. + apply r. + intros i j. + unfold le, sb, le', le in j |-. + apply backforth in j. + specialize q with (i := fun y => i (fun v:V => sb v (down U) le' (forth _ y))). + apply q. + exact j. + Qed. + + Lemma lemma2 : (forall i:U -> Prop, induct i -> up (i WF)) -> False. + Proof. + intro x. + generalize (x (fun u => down (I u)) lemma1). + intro r; apply back in r. + apply r. + intros i H0. + apply (x (fun y => i (fun v => sb v (down U) le' (forth _ y)))). + unfold le, WF in H0. + apply back in H0. + exact H0. + Qed. + + Theorem paradox : False. + Proof. + exact (lemma2 Omega). + Qed. + +End Hurkens. + +Definition informative (x : bool) := + match x with + | true => Type + | false => Prop + end. + +Definition depsort (T : Type) (x : bool) : informative x := + match x with + | true => T + | false => True + end. + +(** This definition should fail *) +Definition Box (T : Type1) : Prop := Lift T. + +Definition prop {T : Type1} (t : Box T) : T := t. +Definition wrap {T : Type1} (t : T) : Box T := t. + +Definition down (x : Type1) : Prop := Box x. +Definition up (x : Prop) : Type1 := x. + +Fail Definition back A : up (down A) -> A := @prop A. + +Fail Definition forth (A : Type1) : A -> up (down A) := @wrap A. + +Fail Definition backforth (A:Type1) (P:A->Type) (a:A) : + P (back A (forth A a)) -> P a := fun H => H. + +Fail Definition backforth_r (A:Type1) (P:A->Type) (a:A) : + P a -> P (back A (forth A a)) := fun H => H. + +Theorem pandora : False. + Fail apply (paradox down up back forth backforth backforth_r). + admit. +Qed. + +Print Assumptions pandora. diff --git a/test-suite/bugs/closed/3315.v b/test-suite/bugs/closed/3315.v new file mode 100644 index 00000000..b69097f9 --- /dev/null +++ b/test-suite/bugs/closed/3315.v @@ -0,0 +1,37 @@ +Set Universe Polymorphism. +Set Primitive Projections. +Set Implicit Arguments. +Record sigT {A : Type} (P : A -> Type) := existT { projT1 : A; projT2 : P projT1 }. +Arguments existT {A} _ _ _. +Definition unpack_sigma' {A} {P : A -> Type} (Q : sigT P -> Type) (u : sigT P) : + Q (existT _ (projT1 u) (projT2 u)) -> Q u + := + fun H => + (let (x,p) as u return (Q (existT _ (projT1 u) (projT2 u)) -> Q u) := u in fun x : Q (existT _ _ p) => x) H. (* success *) +Definition unpack_sigma {A} {P : A -> Type} (Q : sigT P -> Type) (u : sigT P) : + Q (existT _ (projT1 u) (projT2 u)) -> Q u + := + fun H => + (let (x,p) as u return (Q (existT _ (projT1 u) (projT2 u)) -> Q u) := u in fun x => x) H. +(* Toplevel input, characters 219-229: +Error: +In environment +A : Type +P : A -> Type +Q : sigT P -> Type +u : sigT P +H : Q {| projT1 := projT1 u; projT2 := projT2 u |} +x : A +p : P x +The term + "fun + x : Q + {| + projT1 := projT1 {| projT1 := x; projT2 := p |}; + projT2 := projT2 {| projT1 := x; projT2 := p |} |} => x" has type + "Q + {| + projT1 := projT1 {| projT1 := x; projT2 := p |}; + projT2 := projT2 {| projT1 := x; projT2 := p |} |} -> +... " +*) diff --git a/test-suite/bugs/closed/3317.v b/test-suite/bugs/closed/3317.v new file mode 100644 index 00000000..8d152894 --- /dev/null +++ b/test-suite/bugs/closed/3317.v @@ -0,0 +1,94 @@ +Set Implicit Arguments. +Module A. + Set Universe Polymorphism. + Set Primitive Projections. + Set Asymmetric Patterns. + Inductive paths {A} (x : A) : A -> Type := idpath : paths x x + where "x = y" := (@paths _ x y) : type_scope. + Record sigT {A : Type} (P : A -> Type) := existT { projT1 : A; projT2 : P projT1 }. + Arguments existT {A} _ _ _. + Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + Notation "x .1" := (projT1 x) (at level 3). + Notation "x .2" := (projT2 x) (at level 3). + Notation "( x ; y )" := (existT _ x y). + Set Printing All. + Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P) + (pq : sigT (fun p : u.1 = v.1 => transport _ p u.2 = v.2)) + : u = v + := match pq with + | existT p q => + match u, v return (forall p0 : (u.1 = v.1), (transport P p0 u.2 = v.2) -> (u=v)) with + | (x;y), (x';y') => fun p1 (q1 : transport P p1 (existT P x y).2 = (existT P x' y').2) => + match p1 in (_ = x'') return (forall y'', (transport _ p1 y = y'') -> (x;y)=(x'';y'')) with + | idpath => fun y' (q2 : transport _ (@idpath _ _) y = y') => + match q2 in (_ = y'') return (x;y) = (x;y'') with + | idpath => @idpath _ _ + end + end y' q1 + end p q + end. + (* Toplevel input, characters 341-357: +Error: +In environment +A : Type +P : forall _ : A, Type +u : @sigT A P +v : @sigT A P +pq : +@sigT (@paths A (projT1 u) (projT1 v)) + (fun p : @paths A (projT1 u) (projT1 v) => + @paths (P (projT1 v)) (@transport A P (projT1 u) (projT1 v) p (projT2 u)) + (projT2 v)) +p : @paths A (projT1 u) (projT1 v) +q : +@paths (P (projT1 v)) (@transport A P (projT1 u) (projT1 v) p (projT2 u)) + (projT2 v) +x : A +y : P x +x' : A +y' : P x' +p1 : @paths A (projT1 (@existT A P x y)) (projT1 (@existT A P x' y')) +The term "projT2 (@existT A P x y)" has type "P (projT1 (@existT A P x y))" +while it is expected to have type "P (projT1 (@existT A P x y))". + *) +End A. + +Module B. + Set Universe Polymorphism. + Set Primitive Projections. + Set Asymmetric Patterns. + Inductive paths {A} (x : A) : A -> Type := idpath : paths x x + where "x = y" := (@paths _ x y) : type_scope. + Record sigT {A : Type} (P : A -> Type) := existT { projT1 : A; projT2 : P projT1 }. + Arguments existT {A} _ _ _. + Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + Notation "x .1" := (projT1 x) (at level 3). + Notation "x .2" := (projT2 x) (at level 3). + Notation "( x ; y )" := (existT _ x y). + Set Printing All. + + Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P) + (pq : sigT (fun p : u.1 = v.1 => transport _ p u.2 = v.2)) + : u = v. + Proof. + destruct u as [x y]. + destruct v. (* Toplevel input, characters 0-11: +Error: Illegal application: +The term "transport" of type + "forall (A : Type) (P : forall _ : A, Type) (x y : A) + (_ : @paths A x y) (_ : P x), P y" +cannot be applied to the terms + "A" : "Type" + "P" : "forall _ : A, Type" + "projT1 (@existT A P x y)" : "A" + "projT1 v" : "A" + "p" : "@paths A (projT1 (@existT A P x y)) (projT1 v)" + "projT2 (@existT A P x y)" : "P (projT1 (@existT A P x y))" +The 5th term has type "@paths A (projT1 (@existT A P x y)) (projT1 v)" +which should be coercible to + "@paths A (projT1 (@existT A P x y)) (projT1 v)". + *) + Abort. +End B. diff --git a/test-suite/bugs/closed/3319.v b/test-suite/bugs/closed/3319.v new file mode 100644 index 00000000..bb5853dd --- /dev/null +++ b/test-suite/bugs/closed/3319.v @@ -0,0 +1,25 @@ +(* File reduced by coq-bug-finder from original input, then from 5353 lines to 4545 lines, then from 4513 lines to 4504 lines, then from 4515 lines to 4508 lines, then from 4519 lines to 132 lines, then from 111 lines to 66 lines, then from 68 lines to 35 lines *) +Set Implicit Arguments. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a + where "x = y" := (@paths _ x y) : type_scope. + +Record PreCategory := { obj :> Type; morphism : obj -> obj -> Type }. +Record NotionOfStructure (X : PreCategory) := + { structure :> X -> Type; + is_structure_homomorphism + : forall x y (f : morphism X x y) (a : structure x) (b : structure y), Type }. + +Section precategory. + Variable X : PreCategory. + Variable P : NotionOfStructure X. + Local Notation object := { x : X & P x }. + Record morphism' (xa yb : object) := {}. + + Lemma issig_morphism xa yb + : { f : morphism X (projT1 xa) (projT1 yb) + & is_structure_homomorphism _ _ _ f (projT2 xa) (projT2 yb) } + = morphism' xa yb. + Proof. + admit. + Defined. \ No newline at end of file diff --git a/test-suite/bugs/closed/3321.v b/test-suite/bugs/closed/3321.v new file mode 100644 index 00000000..07e3b3cb --- /dev/null +++ b/test-suite/bugs/closed/3321.v @@ -0,0 +1,18 @@ +(* File reduced by coq-bug-finder from original input, then from 5302 lines to 4649 lines, then from 4660 lines to 355 lines, then from 360 lines to 269 lines, then from 269 lines to 175 lines, then from 144 lines to 119 lines, then from 103 lines to 83 lines, then from 86 lines to 36 lines, then from 37 lines to 17 lines *) + +Axiom admit : forall {T}, T. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. +Record Equiv A B := BuildEquiv { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }. +Definition equiv_path (A B : Type) (p : A = B) : Equiv A B := admit. +Class Univalence := { isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B) }. +Definition path_universe `{Univalence} {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B) := admit. +Context `{ua:Univalence}. +Variable A:Type. +Goal forall (I : Type) (f : I -> A), + {p : I = {a : A & @hfiber I A f a} & True }. +intros. +clear. +try exists (path_universe admit). (* Toplevel input, characters 15-44: +Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/closed/3322.v b/test-suite/bugs/closed/3322.v new file mode 100644 index 00000000..925f22a2 --- /dev/null +++ b/test-suite/bugs/closed/3322.v @@ -0,0 +1,23 @@ +(* File reduced by coq-bug-finder from original input, then from 11971 lines to 11753 lines, then from 7702 lines to 564 lines, then from 571 lines to 61 lines *) +Set Asymmetric Patterns. +Axiom admit : forall {T}, T. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P) + (pq : {p : (projT1 u) = (projT1 v) & transport _ p (projT2 u) = (projT2 v)}) +: u = v. +Proof. + destruct pq as [p q], u as [x y], v as [x' y']; simpl in *. + destruct p, q; simpl; reflexivity. +Defined. +Arguments path_sigma_uncurried : simpl never. +Section opposite. + Let opposite_functor_involutive_helper + := @path_sigma_uncurried admit admit (existT _ admit admit) admit (existT _ admit admit). + + Goal True. + Opaque path_sigma_uncurried. + simpl in *. + Transparent path_sigma_uncurried. + (* This command should fail with "Error: Failed to progress.", as it does in 8.4; the simpl never directive should prevent simpl from progressing *) + Fail progress simpl in *. diff --git a/test-suite/bugs/closed/3323.v b/test-suite/bugs/closed/3323.v new file mode 100644 index 00000000..fb5a8a7e --- /dev/null +++ b/test-suite/bugs/closed/3323.v @@ -0,0 +1,77 @@ +(* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* File reduced by coq-bug-finder from original input, then from 5302 lines to 4649 lines, then from 4660 lines to 355 lines, then from 360 lines to 269 lines, then from 269 lines to 175 lines, then from 144 lines to 119 lines, then from 297 lines to 117 lines, then from 95 lines to 79 lines, then from 82 lines to 68 lines *) + +Set Universe Polymorphism. +Generalizable All Variables. +Inductive sigT {A:Type} (P:A -> Type) : Type := existT : forall x:A, P x -> sigT P. +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. +Definition projT1 {A} {P : A -> Type} (x : sigT P) : A := let (a, _) := x in a. +Definition projT2 {A} {P : A -> Type} (x : sigT P) : P (projT1 x) := let (a, h) return P (projT1 x) := x in h. +Axiom admit : forall {T}, T. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. +Record Equiv A B := BuildEquiv { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Existing Instance equiv_isequiv. +Global Instance isequiv_inverse `{IsEquiv A B f} : IsEquiv (@equiv_inv _ _ f _) | 10000 := admit. +Definition equiv_path_sigma `(P : A -> Type) (u v : sigT P) +: Equiv {p : projT1 u = projT1 v & transport _ p (projT2 u) = projT2 v} (u = v) := admit. +Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }. +Definition path_universe {A B : Type} (f : A -> B) : (A = B) := admit. +Section AssumeFunext. + Let equiv_fibration_replacement_eissect {B C f} + : forall x : {y : B & {x : C & f x = y}}, + existT _ (f (projT1 (projT2 x))) (existT _ (projT1 (projT2 x)) idpath) = x. + admit. + Defined. + Definition equiv_fibration_replacement {B C} (f:C ->B): + Equiv C {y:B & {x:C & f x = y}}. + Proof. + refine (BuildEquiv + _ _ _ + (BuildIsEquiv + C {y:B & {x:C & f x = y}} + (fun c => existT _ (f c) (existT _ c idpath)) + (fun c => projT1 (projT2 c)) + equiv_fibration_replacement_eissect)). + Defined. + Definition equiv_total_paths (A : Type) (P : A-> Type) (x y : sigT P) : + Equiv (x = y) { p : projT1 x = projT1 y & transport P p (projT2 x) = (projT2 y) } + := BuildEquiv _ _ (@equiv_inv _ _ _ (equiv_path_sigma P x y)) _. + Variable A:Type. + Definition Fam A:=sigT (fun I:Type => I->A). + Definition p2f: (A->Type)-> Fam A := fun Q:(A->Type) => existT _ (sigT Q) (@projT1 _ _). + Definition f2p: Fam A -> (A->Type) := fun F => let (I, f) := F in (fun a => (hfiber f a)). + Definition exp {U V:Type}(w:Equiv U V):Equiv (U->A) (V->A). + exists (fun f:(U->A)=> (fun x => (f (@equiv_inv _ _ w _ x)))). + admit. + Defined. + Goal { h : Fam A -> A -> Type & Sect h p2f }. + exists f2p. + intros [I f]. + set (e:=@equiv_total_paths _ _ (@existT Type (fun I0 : Type => I0 -> A) I f) + (existT _ {a : A & hfiber f a} (@projT1 _ _))). + simpl in e. + cut ( {p : I = {a : A & @hfiber I A f a} & + @transport _ (fun I0 : Type => I0 -> A) _ _ p f = @projT1 _ _}). + { intro X. + apply (inverse (@equiv_inv _ _ _ e X)). } + set (w:=@equiv_fibration_replacement A I f). + exists (path_universe w). + assert (forall x, (exp w) f x = projT1 x); [ | admit ]. + intros [a [i p]]. + exact p. + Qed. +(* Toplevel input, characters 15-19: +Error: In pattern-matching on term "x" the branch for constructor +"existT(*Top.256 Top.258*)" has type + "forall (I : Type) (f : I -> A), + existT (fun I0 : Type => I0 -> A) {a : A & hfiber f a} projT1 = + existT (fun I0 : Type => I0 -> A) I f" which should be + "forall (x : Type) (H : x -> A), + p2f (f2p (existT (fun I : Type => I -> A) x H)) = + existT (fun I : Type => I -> A) x H". + *) diff --git a/test-suite/bugs/closed/3324.v b/test-suite/bugs/closed/3324.v new file mode 100644 index 00000000..9cd6e4c2 --- /dev/null +++ b/test-suite/bugs/closed/3324.v @@ -0,0 +1,47 @@ +Module ETassi. + Axiom admit : forall {T}, T. + Class IsHProp (A : Type) : Type := {}. + Class IsHSet (A : Type) : Type := {}. + Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. + Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. + Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). + Global Instance isset_hProp : IsHSet hProp | 0. + + Check (eq_refl _ : setT (default_HSet _ _) = hProp). + Check (eq_refl _ : setT _ = hProp). +End ETassi. + +Module JGross. + (* File reduced by coq-bug-finder from original input, then from 6462 lines to 5760 lines, then from 5761 lines to 181 lines, then from 191 lines to 181 lines, then from 181 lines to 83 lines, then from 87 lines to 27 lines *) + Axiom admit : forall {T}, T. + Class IsHProp (A : Type) : Type := {}. + Class IsHSet (A : Type) : Type := {}. + Inductive Unit : Set := tt. + Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. + Definition Unit_hp:hProp:=(hp Unit admit). + Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. + Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). + Global Instance isset_hProp : IsHSet hProp | 0. + Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, + forall g h: Y -> Z, (fun x => g (f x)) = (fun x => h (f x)) -> g = h. + Lemma isepi_issurj {X Y} (f:X->Y): isepi f -> True. + Proof. + intros epif. + set (g :=fun _:Y => Unit_hp). + pose proof (epif (default_HSet hProp isset_hProp) g). + specialize (epif _ g). + (* Toplevel input, characters 34-35: +Error: +In environment +X : Type +Y : Type +f : X -> Y +epif : isepi f +g := fun _ : Y => Unit_hp : Y -> hProp +H : forall h : Y -> default_HSet hProp isset_hProp, + (fun x : X => g (f x)) = (fun x : X => h (f x)) -> g = h +The term "g" has type "Y -> hProp" while it is expected to have type + "Y -> ?30". + *) + Abort. +End JGross. diff --git a/test-suite/bugs/closed/3325.v b/test-suite/bugs/closed/3325.v new file mode 100644 index 00000000..36c065eb --- /dev/null +++ b/test-suite/bugs/closed/3325.v @@ -0,0 +1,48 @@ +Typeclasses eauto := debug. +Set Printing All. + +Axiom SProp : Set. +Axiom sp : SProp. + +(* If we hardcode valueType := nat, it goes through *) +Class StateIs := { + valueType : Type; + stateIs : valueType -> SProp +}. + +Instance NatStateIs : StateIs := { + valueType := nat; + stateIs := fun _ => sp +}. +Canonical Structure NatStateIs. + +Class LogicOps F := { land: F -> F }. +Instance : LogicOps SProp. Admitted. +Instance : LogicOps Prop. Admitted. + +Parameter (n : nat). +(* If this is a [Definition], the resolution goes through fine. *) +Notation vn := (@stateIs _ n). +Definition vn' := (@stateIs _ n). +Definition GOOD : SProp := + @land _ _ vn'. +(* This doesn't resolve, if PropLogicOps is defined later than SPropLogicOps *) +Definition BAD : SProp := + @land _ _ vn. + + +Class A T := { foo : T -> Prop }. +Instance: A nat. Admitted. +Instance: A Set. Admitted. + +Class B := { U : Type ; b : U }. +Instance bi: B := {| U := nat ; b := 0 |}. +Canonical Structure bi. + +Notation b0N := (@b _ : nat). +Notation b0Ni := (@b bi : nat). +Definition b0D := (@b _ : nat). +Definition GOOD1 := (@foo _ _ b0D). +Definition GOOD2 := (let x := b0N in @foo _ _ x). +Definition GOOD3 := (@foo _ _ b0Ni). +Definition BAD1 := (@foo _ _ b0N). (* Error: The term "b0Ni" has type "nat" while it is expected to have type "Set". *) diff --git a/test-suite/bugs/closed/3326.v b/test-suite/bugs/closed/3326.v new file mode 100644 index 00000000..4d7e9f77 --- /dev/null +++ b/test-suite/bugs/closed/3326.v @@ -0,0 +1,19 @@ +Class ORDER A := Order { + LEQ : A -> A -> bool; + leqRefl: forall x, true = LEQ x x +}. + +Section XXX. + +Variable A:Type. +Variable (O:ORDER A). +Definition aLeqRefl := @leqRefl _ O. + +Lemma OK : forall x, true = LEQ x x. +Proof. + intros. + unfold LEQ. + destruct O. + clear. + Fail apply aLeqRefl. +Abort. diff --git a/test-suite/bugs/closed/3329.v b/test-suite/bugs/closed/3329.v new file mode 100644 index 00000000..f7e368f8 --- /dev/null +++ b/test-suite/bugs/closed/3329.v @@ -0,0 +1,93 @@ +(* File reduced by coq-bug-finder from original input, then from 12095 lines to 869 lines, then from 792 lines to 504 lines, then from 487 lines to 353 lines, then from 258 lines to 174 lines, then from 164 lines to 132 lines, then from 129 lines to 99 lines *) +Set Universe Polymorphism. +Generalizable All Variables. +Axiom admit : forall {T}, T. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Notation "g 'o' f" := (compose g f). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) : Type := forall x:A, f x = g x. +Hint Unfold pointwise_paths : typeclass_instances. +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) +: forall x, f x = g x + := fun x => match h with idpath => idpath end. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }. +Class IsHSet (A : Type) := { _ : False }. +Class Funext := { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + trunc_morphism : forall s d, IsHSet (morphism s d) }. + +Definition trunc_equiv `(f : A -> B) `{IsHSet A} `{IsEquiv A B f} : IsHSet B := admit. +Global Instance trunc_forall `{Funext} `{P : A -> Type} `{forall a, IsHSet (P a)} +: IsHSet (forall a, P a) | 100. +Proof. + generalize dependent P. + intro P. + assert (f : forall a, P a) by admit. + assert (g : forall a, P a) by admit. + pose (@trunc_equiv (forall x : A, @paths (P x) (f x) (g x)) + (@paths (forall x : A, P x) f g) + (@equiv_inv (@paths (forall x : A, P x) f g) + (forall x : A, @paths (P x) (f x) (g x)) + (@apD10 A P f g) (@isequiv_apD10 H A P f g))). + admit. +Defined. +Record Functor (C D : PreCategory) := { object_of :> C -> D }. +Definition identity C : Functor C C := Build_Functor C C admit. +Notation "1" := (identity _) : functor_scope. +Definition functor_category (C D : PreCategory) : PreCategory + := @Build_PreCategory (Functor C D) admit admit. +Notation "C -> D" := (functor_category C D) : category_scope. +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Global Existing Instance iss. +Definition set_cat `{Funext} : PreCategory := + @Build_PreCategory hSet + (fun x y => x -> y) + _. + +Section hom_functor. + Context `{Funext}. + Variable C : PreCategory. + + Local Notation obj_of c'c := + (BuildhSet + (morphism + C + c'c + c'c) + admit). + Let hom_functor_morphism_of s's d'd (hf : morphism C s's d'd) + : morphism set_cat (obj_of s's) (obj_of d'd) + := admit. + + Definition hom_functor : Functor C set_cat := admit. +End hom_functor. +Local Open Scope category_scope. +Local Open Scope functor_scope. +Context `{Funext}. +Variable D : PreCategory. +Set Printing Universes. +Check hom_functor D o 1. +(* Toplevel input, characters 20-44: +Error: Illegal application: +The term "@set_cat" of type "(Funext -> PreCategory)%type" +cannot be applied to the term + "H" : "Funext" +This term has type "Funext" which should be coercible to +"Funext". *) +(* The command has indeed failed with message: +=> Error: Illegal application: +The term "@set_cat@{Top.345 Top.346 Top.331 Top.332 Top.337 Top.338 Top.339}" +of type + "(Funext@{Top.346 Top.346 Top.331 Top.332 Top.346} -> PreCategory@{Top.345 + Top.346})%type" +cannot be applied to the term + "H@{Top.346 Top.330 Top.331 Top.332 Top.333}" + : "Funext@{Top.346 Top.330 Top.331 Top.332 Top.333}" +This term has type "Funext@{Top.346 Top.330 Top.331 Top.332 Top.333}" +which should be coercible to + "Funext@{Top.346 Top.346 Top.331 Top.332 Top.346}". +*) diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v new file mode 100644 index 00000000..15303cca --- /dev/null +++ b/test-suite/bugs/closed/3330.v @@ -0,0 +1,1110 @@ +(* File reduced by coq-bug-finder from original input, then from 12106 lines to 1070 lines *) +Set Universe Polymorphism. +Definition setleq (A : Type@{i}) (B : Type@{j}) := A : Type@{j}. + +Inductive foo : Type@{l} := bar : foo . +Section MakeEq. + Variables (a : foo@{i}) (b : foo@{j}). + + Let t := $(let ty := type of b in exact ty)$. + Definition make_eq (x:=b) := a : t. +End MakeEq. + +Definition same (x : foo@{i}) (y : foo@{i}) := x. + +Section foo. + + Variables x : foo@{i}. + Variables y : foo@{j}. + + Let AleqB := let foo := make_eq x y in (Type * Type)%type. + + Definition baz := same x y. +End foo. + +Definition baz' := Eval unfold baz in baz@{i j k l}. + +Module Export HoTT_DOT_Overture. +Module Export HoTT. +Module Export Overture. + +Definition relation (A : Type) := A -> A -> Type. +Class Symmetric {A} (R : relation A) := + symmetry : forall x y, R x y -> R y x. + +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := + fun x => g (f x). + +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. + +Open Scope function_scope. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. + +Notation "x = y" := (x = y :>_) : type_scope. + +Delimit Scope path_scope with path. + +Local Open Scope path_scope. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. + +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Instance symmetric_paths {A} : Symmetric (@paths A) | 0 := @inverse A. + +Notation "1" := idpath : path_scope. + +Notation "p @ q" := (concat p q) (at level 20) : path_scope. + +Notation "p ^" := (inverse p) (at level 3) : path_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) : Type + := forall x:A, f x = g x. + +Hint Unfold pointwise_paths : typeclass_instances. + +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. + +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) + : f == g + := fun x => match h with idpath => 1 end. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Delimit Scope equiv_scope with equiv. + +Local Open Scope equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) +}. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint nat_to_trunc_index (n : nat) : trunc_index + := match n with + | 0 => trunc_S (trunc_S minus_two) + | S n' => trunc_S (nat_to_trunc_index n') + end. + +Coercion nat_to_trunc_index : nat >-> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Notation IsHSet := (IsTrunc 0). + +Class Funext := + { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. + +Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : + f == g -> f = g + := + (@apD10 A P f g)^-1. + +End Overture. + +End HoTT. + +End HoTT_DOT_Overture. + +Module Export HoTT_DOT_categories_DOT_Category_DOT_Core. + +Module Export HoTT. +Module Export categories. +Module Export Category. +Module Export Core. +Set Universe Polymorphism. + +Set Implicit Arguments. +Delimit Scope morphism_scope with morphism. + +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. + +Record PreCategory := + Build_PreCategory' { + object :> Type; + morphism : object -> object -> Type; + + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1); + + associativity_sym : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + m3 o (m2 o m1) = (m3 o m2) o m1; + + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f; + + identity_identity : forall x, identity x o identity x = identity x; + + trunc_morphism : forall s d, IsHSet (morphism s d) + }. + +Bind Scope category_scope with PreCategory. + +Arguments identity [!C%category] x%object : rename. +Arguments compose [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + +Definition Build_PreCategory + object morphism compose identity + associativity left_identity right_identity + := @Build_PreCategory' + object + morphism + compose + identity + associativity + (fun _ _ _ _ _ _ _ => symmetry _ _ (associativity _ _ _ _ _ _ _)) + left_identity + right_identity + (fun _ => left_identity _ _ _). + +Existing Instance trunc_morphism. + +Hint Resolve @left_identity @right_identity @associativity : category morphism. + +Module Export CategoryCoreNotations. + + Infix "o" := compose : morphism_scope. +End CategoryCoreNotations. +End Core. + +End Category. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Category_DOT_Core. + +Module Export HoTT_DOT_types_DOT_Forall. + +Module Export HoTT. +Module Export types. +Module Export Forall. +Generalizable Variables A B f g e n. + +Section AssumeFunext. + +Global Instance trunc_forall `{P : A -> Type} `{forall a, IsTrunc n (P a)} + : IsTrunc n (forall a, P a) | 100. + +admit. +Defined. +End AssumeFunext. + +End Forall. + +End types. + +End HoTT. + +End HoTT_DOT_types_DOT_Forall. + +Module Export HoTT_DOT_types_DOT_Prod. + +Module Export HoTT. +Module Export types. +Module Export Prod. +Local Open Scope path_scope. + +Definition path_prod_uncurried {A B : Type} (z z' : A * B) + (pq : (fst z = fst z') * (snd z = snd z')) + : (z = z') + := match pq with (p,q) => + match z, z' return + (fst z = fst z') -> (snd z = snd z') -> (z = z') with + | (a,b), (a',b') => fun p q => + match p, q with + idpath, idpath => 1 + end + end p q + end. + +Definition path_prod {A B : Type} (z z' : A * B) : + (fst z = fst z') -> (snd z = snd z') -> (z = z') + := fun p q => path_prod_uncurried z z' (p,q). + +Definition path_prod' {A B : Type} {x x' : A} {y y' : B} + : (x = x') -> (y = y') -> ((x,y) = (x',y')) + := fun p q => path_prod (x,y) (x',y') p q. + +End Prod. + +End types. + +End HoTT. + +End HoTT_DOT_types_DOT_Prod. + +Module Export HoTT_DOT_categories_DOT_Functor_DOT_Core. + +Module Export HoTT. +Module Export categories. +Module Export Functor. +Module Export Core. +Set Universe Polymorphism. + +Set Implicit Arguments. +Delimit Scope functor_scope with functor. + +Local Open Scope morphism_scope. + +Section Functor. + + Variable C : PreCategory. + Variable D : PreCategory. + + Record Functor := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + composition_of : forall s d d' + (m1 : morphism C s d) (m2: morphism C d d'), + morphism_of _ _ (m2 o m1) + = (morphism_of _ _ m2) o (morphism_of _ _ m1); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) + }. + +End Functor. +Bind Scope functor_scope with Functor. + +Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. +Module Export FunctorCoreNotations. + + Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. +End FunctorCoreNotations. +End Core. + +End Functor. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Functor_DOT_Core. + +Module Export HoTT_DOT_categories_DOT_Category_DOT_Morphisms. + +Module Export HoTT. +Module Export categories. +Module Export Category. +Module Export Morphisms. +Set Universe Polymorphism. + +Local Open Scope morphism_scope. + +Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := + { + morphism_inverse : morphism C d s; + left_inverse : morphism_inverse o m = identity _; + right_inverse : m o morphism_inverse = identity _ + }. + +Class Isomorphic {C : PreCategory} s d := + { + morphism_isomorphic :> morphism C s d; + isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic + }. + +Module Export CategoryMorphismsNotations. + + Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope. + +End CategoryMorphismsNotations. +End Morphisms. + +End Category. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Category_DOT_Morphisms. + +Module Export HoTT_DOT_categories_DOT_Category_DOT_Dual. + +Module Export HoTT. +Module Export categories. +Module Export Category. +Module Export Dual. +Set Universe Polymorphism. + +Local Open Scope morphism_scope. + +Section opposite. + + Definition opposite (C : PreCategory) : PreCategory + := @Build_PreCategory' + C + (fun s d => morphism C d s) + (identity (C := C)) + (fun _ _ _ m1 m2 => m2 o m1) + (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _) + (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _) + (fun _ _ => @right_identity _ _ _) + (fun _ _ => @left_identity _ _ _) + (@identity_identity C) + _. +End opposite. + +Module Export CategoryDualNotations. + + Notation "C ^op" := (opposite C) (at level 3) : category_scope. +End CategoryDualNotations. +End Dual. + +End Category. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Category_DOT_Dual. + +Module Export HoTT_DOT_categories_DOT_Functor_DOT_Composition_DOT_Core. + +Module Export HoTT. +Module Export categories. +Module Export Functor. +Module Export Composition. +Module Export Core. +Set Universe Polymorphism. + +Set Implicit Arguments. +Local Open Scope morphism_scope. + +Section composition. + + Variable C : PreCategory. + Variable D : PreCategory. + Variable E : PreCategory. + Variable G : Functor D E. + Variable F : Functor C D. + + Local Notation c_object_of c := (G (F c)) (only parsing). + + Local Notation c_morphism_of m := (morphism_of G (morphism_of F m)) (only parsing). + + Let compose_composition_of' s d d' + (m1 : morphism C s d) (m2 : morphism C d d') + : c_morphism_of (m2 o m1) = c_morphism_of m2 o c_morphism_of m1. +admit. +Defined. + Definition compose_composition_of s d d' m1 m2 + := Eval cbv beta iota zeta delta + [compose_composition_of'] in + @compose_composition_of' s d d' m1 m2. + Let compose_identity_of' x + : c_morphism_of (identity x) = identity (c_object_of x). + +admit. +Defined. + Definition compose_identity_of x + := Eval cbv beta iota zeta delta + [compose_identity_of'] in + @compose_identity_of' x. + Definition compose : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => morphism_of G (morphism_of F m)) + compose_composition_of + compose_identity_of. + +End composition. +Module Export FunctorCompositionCoreNotations. + + Infix "o" := compose : functor_scope. +End FunctorCompositionCoreNotations. +End Core. + +End Composition. + +End Functor. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Functor_DOT_Composition_DOT_Core. + +Module Export HoTT_DOT_categories_DOT_Functor_DOT_Dual. + +Module Export HoTT. +Module Export categories. +Module Export Functor. +Module Export Dual. +Set Universe Polymorphism. + +Set Implicit Arguments. + +Section opposite. + + Variable C : PreCategory. + Variable D : PreCategory. + Definition opposite (F : Functor C D) : Functor C^op D^op + := Build_Functor (C^op) (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). + +End opposite. +Module Export FunctorDualNotations. + + Notation "F ^op" := (opposite F) : functor_scope. +End FunctorDualNotations. +End Dual. + +End Functor. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Functor_DOT_Dual. + +Module Export HoTT_DOT_categories_DOT_Functor_DOT_Identity. + +Module Export HoTT. +Module Export categories. +Module Export Functor. +Module Export Identity. +Set Universe Polymorphism. + +Section identity. + + Definition identity C : Functor C C + := Build_Functor C C + (fun x => x) + (fun _ _ x => x) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). +End identity. +Module Export FunctorIdentityNotations. + + Notation "1" := (identity _) : functor_scope. +End FunctorIdentityNotations. +End Identity. + +End Functor. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Functor_DOT_Identity. + +Module Export HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Core. + +Module Export HoTT. +Module Export categories. +Module Export NaturalTransformation. +Module Export Core. +Set Universe Polymorphism. + +Set Implicit Arguments. +Local Open Scope morphism_scope. + +Section NaturalTransformation. + + Variable C : PreCategory. + Variable D : PreCategory. + Variables F G : Functor C D. + + Record NaturalTransformation := + Build_NaturalTransformation' { + components_of :> forall c, morphism D (F c) (G c); + commutes : forall s d (m : morphism C s d), + components_of d o F _1 m = G _1 m o components_of s; + + commutes_sym : forall s d (m : C.(morphism) s d), + G _1 m o components_of s = components_of d o F _1 m + }. + +End NaturalTransformation. +End Core. + +End NaturalTransformation. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Core. + +Module Export HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Dual. + +Module Export HoTT. +Module Export categories. +Module Export NaturalTransformation. +Module Export Dual. +Set Universe Polymorphism. + +Section opposite. + + Variable C : PreCategory. + Variable D : PreCategory. + + Definition opposite + (F G : Functor C D) + (T : NaturalTransformation F G) + : NaturalTransformation G^op F^op + := Build_NaturalTransformation' (G^op) (F^op) + (components_of T) + (fun s d => commutes_sym T d s) + (fun s d => commutes T d s). + +End opposite. + +End Dual. + +End NaturalTransformation. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Dual. + +Module Export HoTT_DOT_categories_DOT_Category_DOT_Strict. + +Module Export HoTT. +Module Export categories. +Module Export Category. +Module Export Strict. + +Export Category.Core. +Set Universe Polymorphism. + +End Strict. + +End Category. + +End categories. + +End HoTT. + +End HoTT_DOT_categories_DOT_Category_DOT_Strict. + +Module Export HoTT. +Module Export categories. +Module Export Category. +Module Export Prod. +Set Universe Polymorphism. + +Local Open Scope morphism_scope. + +Section prod. + + Variable C : PreCategory. + Variable D : PreCategory. + Definition prod : PreCategory. + + refine (@Build_PreCategory + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) + * morphism D (snd s) (snd d))%type) + (fun x => (identity (fst x), identity (snd x))) + (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1)) + _ + _ + _ + _); admit. + Defined. +End prod. +Module Export CategoryProdNotations. + + Infix "*" := prod : category_scope. +End CategoryProdNotations. +End Prod. + +End Category. + +End categories. + +End HoTT. + +Module Functor. +Module Export Prod. +Set Universe Polymorphism. + +Set Implicit Arguments. +Local Open Scope morphism_scope. + +Section proj. + + Context {C : PreCategory}. + Context {D : PreCategory}. + Definition fst : Functor (C * D) C + := Build_Functor (C * D) C + (@fst _ _) + (fun _ _ => @fst _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). + + Definition snd : Functor (C * D) D + := Build_Functor (C * D) D + (@snd _ _) + (fun _ _ => @snd _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). + +End proj. + +Section prod. + + Variable C : PreCategory. + Variable D : PreCategory. + Variable D' : PreCategory. + Definition prod (F : Functor C D) (F' : Functor C D') + : Functor C (D * D') + := Build_Functor + C (D * D') + (fun c => (F c, F' c)) + (fun s d m => (F _1 m, F' _1 m)) + (fun _ _ _ _ _ => path_prod' (composition_of F _ _ _ _ _) + (composition_of F' _ _ _ _ _)) + (fun _ => path_prod' (identity_of F _) (identity_of F' _)). + +End prod. +Local Infix "*" := prod : functor_scope. + +Section pair. + + Variable C : PreCategory. + Variable D : PreCategory. + Variable C' : PreCategory. + Variable D' : PreCategory. + Variable F : Functor C D. + Variable F' : Functor C' D'. + Definition pair : Functor (C * C') (D * D') + := (F o fst) * (F' o snd). + +End pair. + +Module Export FunctorProdNotations. + + Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : functor_scope. +End FunctorProdNotations. +End Prod. + +End Functor. + +Module Export HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Composition_DOT_Core. + +Module Export HoTT. +Module categories. +Module Export NaturalTransformation. +Module Export Composition. +Module Export Core. +Set Universe Polymorphism. + +Set Implicit Arguments. +Local Open Scope path_scope. + +Local Open Scope morphism_scope. + +Section composition. + + Section compose. + Variable C : PreCategory. + Variable D : PreCategory. + Variables F F' F'' : Functor C D. + Variable T' : NaturalTransformation F' F''. + + Variable T : NaturalTransformation F F'. + Local Notation CO c := (T' c o T c). + + Definition compose_commutes s d (m : morphism C s d) + : CO d o morphism_of F m = morphism_of F'' m o CO s + := (associativity _ _ _ _ _ _ _ _) + @ ap (fun x => _ o x) (commutes T _ _ m) + @ (associativity_sym _ _ _ _ _ _ _ _) + @ ap (fun x => x o _) (commutes T' _ _ m) + @ (associativity _ _ _ _ _ _ _ _). + + Definition compose_commutes_sym s d (m : morphism C s d) + : morphism_of F'' m o CO s = CO d o morphism_of F m + := (associativity_sym _ _ _ _ _ _ _ _) + @ ap (fun x => x o _) (commutes_sym T' _ _ m) + @ (associativity _ _ _ _ _ _ _ _) + @ ap (fun x => _ o x) (commutes_sym T _ _ m) + @ (associativity_sym _ _ _ _ _ _ _ _). + + Definition compose + : NaturalTransformation F F'' + := Build_NaturalTransformation' F F'' + (fun c => CO c) + compose_commutes + compose_commutes_sym. + + End compose. + End composition. +Module Export NaturalTransformationCompositionCoreNotations. + + Infix "o" := compose : natural_transformation_scope. +End NaturalTransformationCompositionCoreNotations. +End Core. + +End Composition. + +End NaturalTransformation. + +End categories. + +Set Universe Polymorphism. + +Section path_natural_transformation. + + Context `{Funext}. + Variable C : PreCategory. + + Variable D : PreCategory. + Variables F G : Functor C D. + + Global Instance trunc_natural_transformation + : IsHSet (NaturalTransformation F G). + +admit. +Defined. + Section path. + + Variables T U : NaturalTransformation F G. + + Lemma path'_natural_transformation + : components_of T = components_of U + -> T = U. + +admit. +Defined. + Lemma path_natural_transformation + : components_of T == components_of U + -> T = U. + + Proof. + intros. + apply path'_natural_transformation. + apply path_forall; assumption. + Qed. + End path. +End path_natural_transformation. + +Ltac path_natural_transformation := + repeat match goal with + | _ => intro + | _ => apply path_natural_transformation; simpl + end. + +Module Export Identity. +Set Universe Polymorphism. + +Set Implicit Arguments. +Local Open Scope morphism_scope. + +Local Open Scope path_scope. +Section identity. + + Variable C : PreCategory. + Variable D : PreCategory. + + Section generalized. + + Variables F G : Functor C D. + Hypothesis HO : object_of F = object_of G. + Hypothesis HM : transport (fun GO => forall s d, + morphism C s d + -> morphism D (GO s) (GO d)) + HO + (morphism_of F) + = morphism_of G. + Local Notation CO c := (transport (fun GO => morphism D (F c) (GO c)) + HO + (identity (F c))). + + Definition generalized_identity_commutes s d (m : morphism C s d) + : CO d o morphism_of F m = morphism_of G m o CO s. + + Proof. + case HM. +case HO. + exact (left_identity _ _ _ _ @ (right_identity _ _ _ _)^). + Defined. + Definition generalized_identity_commutes_sym s d (m : morphism C s d) + : morphism_of G m o CO s = CO d o morphism_of F m. + +admit. +Defined. + Definition generalized_identity + : NaturalTransformation F G + := Build_NaturalTransformation' + F G + (fun c => CO c) + generalized_identity_commutes + generalized_identity_commutes_sym. + + End generalized. + Definition identity (F : Functor C D) + : NaturalTransformation F F + := Eval simpl in @generalized_identity F F 1 1. + +End identity. +Module Export NaturalTransformationIdentityNotations. + + Notation "1" := (identity _) : natural_transformation_scope. +End NaturalTransformationIdentityNotations. +End Identity. + +Module Export Laws. +Import HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Composition_DOT_Core.HoTT.categories. +Set Universe Polymorphism. + +Local Open Scope natural_transformation_scope. +Section natural_transformation_identity. + + Context `{fs : Funext}. + Variable C : PreCategory. + + Variable D : PreCategory. + + Lemma left_identity (F F' : Functor C D) + (T : NaturalTransformation F F') + : 1 o T = T. + + Proof. + path_natural_transformation; auto with morphism. + Qed. + + Lemma right_identity (F F' : Functor C D) + (T : NaturalTransformation F F') + : T o 1 = T. + + Proof. + path_natural_transformation; auto with morphism. + Qed. +End natural_transformation_identity. +Section associativity. + + Section nt. + + Context `{fs : Funext}. + Definition associativity + C D F G H I + (V : @NaturalTransformation C D F G) + (U : @NaturalTransformation C D G H) + (T : @NaturalTransformation C D H I) + : (T o U) o V = T o (U o V). + + Proof. + path_natural_transformation. + apply associativity. + Qed. + End nt. +End associativity. +End Laws. + +Module Export FunctorCategory. +Module Export Core. +Import HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Composition_DOT_Core.HoTT.categories. +Set Universe Polymorphism. + +Section functor_category. + + Context `{Funext}. + Variable C : PreCategory. + + Variable D : PreCategory. + + Definition functor_category : PreCategory + := @Build_PreCategory (Functor C D) + (@NaturalTransformation C D) + (@identity C D) + (@compose C D) + (@associativity _ C D) + (@left_identity _ C D) + (@right_identity _ C D) + _. + +End functor_category. +Module Export FunctorCategoryCoreNotations. + + Notation "C -> D" := (functor_category C D) : category_scope. +End FunctorCategoryCoreNotations. +End Core. + +End FunctorCategory. + +Module Export Morphisms. +Set Universe Polymorphism. + +Set Implicit Arguments. + +Definition NaturalIsomorphism `{Funext} (C D : PreCategory) F G := + @Isomorphic (C -> D) F G. + +Module Export FunctorCategoryMorphismsNotations. + + Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope. +End FunctorCategoryMorphismsNotations. +End Morphisms. + +Module Export HSet. +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. + +Global Existing Instance iss. +End HSet. + +Module Export Core. +Set Universe Polymorphism. + +Notation cat_of obj := + (@Build_PreCategory obj + (fun x y => x -> y) + (fun _ x => x) + (fun _ _ _ f g => f o g)%core + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ _ _ => idpath) + _). + +Definition set_cat `{Funext} : PreCategory := cat_of hSet. +Set Universe Polymorphism. + +Local Open Scope morphism_scope. + +Section hom_functor. + + Context `{Funext}. + Variable C : PreCategory. + Local Notation obj_of c'c := + (BuildhSet + (morphism + C + (fst (c'c : object (C^op * C))) + (snd (c'c : object (C^op * C)))) + _). + + Let hom_functor_morphism_of s's d'd (hf : morphism (C^op * C) s's d'd) + : morphism set_cat (obj_of s's) (obj_of d'd) + := fun g => snd hf o g o fst hf. + + Definition hom_functor : Functor (C^op * C) set_cat. + + refine (Build_Functor (C^op * C) set_cat + (fun c'c => obj_of c'c) + hom_functor_morphism_of + _ + _); + subst hom_functor_morphism_of; + simpl; admit. + Defined. +End hom_functor. +Set Universe Polymorphism. + +Import Category.Dual Functor.Dual. +Import Category.Prod Functor.Prod. +Import Functor.Composition.Core. +Import Functor.Identity. +Set Universe Polymorphism. + +Local Open Scope functor_scope. +Local Open Scope natural_transformation_scope. +Section Adjunction. + + Context `{Funext}. + Variable C : PreCategory. + Variable D : PreCategory. + Variable F : Functor C D. + Variable G : Functor D C. + + Let Adjunction_Type := + Eval simpl in (hom_functor D) o (F^op, 1) <~=~> (hom_functor C) o (1, G). + + Record AdjunctionHom := + { + mate_of : + @NaturalIsomorphism H + (Prod.prod (Category.Dual.opposite C) D) + (@set_cat H) + (@compose (Prod.prod (Category.Dual.opposite C) D) + (Prod.prod (Category.Dual.opposite D) D) + (@set_cat H) (@hom_functor H D) + (@pair (Category.Dual.opposite C) + (Category.Dual.opposite D) D D + (@opposite C D F) (identity D))) + (@compose (Prod.prod (Category.Dual.opposite C) D) + (Prod.prod (Category.Dual.opposite C) C) + (@set_cat H) (@hom_functor H C) + (@pair (Category.Dual.opposite C) + (Category.Dual.opposite C) D C + (identity (Category.Dual.opposite C)) G)) + }. +End Adjunction. +(* Error: Illegal application: +The term "NaturalIsomorphism" of type + "forall (H : Funext) (C D : PreCategory), + (C -> D)%category -> (C -> D)%category -> Type" +cannot be applied to the terms + "H" : "Funext" + "(C ^op * D)%category" : "PreCategory" + "set_cat" : "PreCategory" + "hom_functor D o (F ^op, 1)" : "Functor (C ^op * D) set_cat" + "hom_functor C o (1, G)" : "Functor (C ^op * D) set_cat" +The 5th term has type "Functor (C ^op * D) set_cat" +which should be coercible to "object (C ^op * D -> set_cat)". +*) +End Core. + +End HoTT. + +End HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Composition_DOT_Core. diff --git a/test-suite/bugs/closed/3331.v b/test-suite/bugs/closed/3331.v new file mode 100644 index 00000000..9cd44bd0 --- /dev/null +++ b/test-suite/bugs/closed/3331.v @@ -0,0 +1,31 @@ +(* File reduced by coq-bug-finder from original input, then from 6303 lines to 66 lines, then from 63 lines to 36 lines *) +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y :> A" := (@paths A x y) : type_scope. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (x = y :>_) : type_scope. +Class Contr_internal (A : Type) := BuildContr { center : A ; contr : (forall y : A, center = y) }. +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. +Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. +Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A) : IsTrunc n (x = y) := H x y. +Notation Contr := (IsTrunc minus_two). +Section groupoid_category. + Variable X : Type. + Context `{H : IsTrunc (trunc_S (trunc_S (trunc_S minus_two))) X}. + Goal X -> True. + intro d. + pose (_ : Contr (idpath = idpath :> (@paths (@paths X d d) idpath idpath))) as H'. (* success *) + clear H'. + compute in H. + change (forall (x y : X) (p q : x = y) (r s : p = q), Contr (r = s)) in H. + assert (H' := H). + set (foo:=_ : Contr (idpath = idpath :> (@paths (@paths X d d) idpath idpath))). (* success *) + clear H' foo. + Set Typeclasses Debug. + pose (_ : Contr (idpath = idpath :> (@paths (@paths X d d) idpath idpath))). +Abort. \ No newline at end of file diff --git a/test-suite/bugs/closed/3332.v b/test-suite/bugs/closed/3332.v new file mode 100644 index 00000000..d86470cd --- /dev/null +++ b/test-suite/bugs/closed/3332.v @@ -0,0 +1,6 @@ +(* -*- coq-prog-args: ("-emacs" "-time") -*- *) +Definition foo : True. +Proof. +Abort. (* Toplevel input, characters 15-21: +Anomaly: Backtrack.backto to a state with no vcs_backup. Please report. *) +(* Anomaly: VernacAbort not handled by Stm. Please report. *) diff --git a/test-suite/bugs/closed/3336.v b/test-suite/bugs/closed/3336.v new file mode 100644 index 00000000..dc358c60 --- /dev/null +++ b/test-suite/bugs/closed/3336.v @@ -0,0 +1,9 @@ +Require Import Setoid. + +Goal forall x y : Type, x = y -> x = y. +intros x y H. +setoid_rewrite H. +reflexivity. +Defined. +(* Toplevel input, characters 0-16: +Anomaly: Uncaught exception Reduction.NotConvertible(_). Please report. *) diff --git a/test-suite/bugs/closed/3337.v b/test-suite/bugs/closed/3337.v new file mode 100644 index 00000000..cd7891f1 --- /dev/null +++ b/test-suite/bugs/closed/3337.v @@ -0,0 +1,4 @@ +Require Import Setoid. +Goal forall x y : Set, x = y -> x = y. +intros x y H. +rewrite_strat subterms H. diff --git a/test-suite/bugs/closed/3338.v b/test-suite/bugs/closed/3338.v new file mode 100644 index 00000000..076cd5e6 --- /dev/null +++ b/test-suite/bugs/closed/3338.v @@ -0,0 +1,4 @@ +Require Import Setoid. +Goal forall x y : Set, x = y -> y = y. +intros x y H. +rewrite_strat try topdown terms H. diff --git a/test-suite/bugs/closed/3344.v b/test-suite/bugs/closed/3344.v new file mode 100644 index 00000000..8255fd6c --- /dev/null +++ b/test-suite/bugs/closed/3344.v @@ -0,0 +1,58 @@ +(* File reduced by coq-bug-finder from original input, then from 716 lines to 197 lines, then from 206 lines to 162 lines, then from 163 lines to 73 lines *) +Require Import Coq.Sets.Ensembles. +Require Import Coq.Strings.String. +Global Set Implicit Arguments. +Global Set Asymmetric Patterns. +Ltac clearbodies := repeat match goal with | [ H := _ |- _ ] => clearbody H end. + +Inductive Comp : Type -> Type := +| Return : forall A, A -> Comp A +| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B. +Inductive computes_to : forall A, Comp A -> A -> Prop := +| ReturnComputes : forall A v, @computes_to A (Return v) v +| BindComputes : forall A B comp_a f comp_a_value comp_b_value, + @computes_to A comp_a comp_a_value + -> @computes_to B (f comp_a_value) comp_b_value + -> @computes_to B (Bind comp_a f) comp_b_value. + +Inductive is_computational : forall A, Comp A -> Prop := +| Return_is_computational : forall A (x : A), is_computational (Return x) +| Bind_is_computational : forall A B (cA : Comp A) (f : A -> Comp B), + is_computational cA + -> (forall a, + @computes_to _ cA a -> is_computational (f a)) + -> is_computational (Bind cA f). +Theorem is_computational_inv A (c : Comp A) +: is_computational c + -> match c with + | Return _ _ => True + | Bind _ _ x f => is_computational x + /\ forall v, computes_to x v + -> is_computational (f v) + end. + admit. +Defined. +Fixpoint is_computational_unique_val A (c : Comp A) {struct c} +: is_computational c -> { a | unique (computes_to c) a }. +Proof. + refine match c as c return is_computational c -> { a | unique (computes_to c) a } with + | Return T x => fun _ => exist (unique (computes_to (Return x))) + x + _ + | Bind _ _ x f + => fun H + => let H' := is_computational_inv H in + let xv := @is_computational_unique_val _ _ (proj1 H') in + let fxv := @is_computational_unique_val _ _ (proj2 H' _ (proj1 (proj2_sig xv))) in + exist (unique (computes_to _)) + (proj1_sig fxv) + _ + end; + clearbodies; + clear is_computational_unique_val; + clear; + first [ abstract admit + | abstract admit ]. +(* [Fail] does not catch the anomaly *) +Defined. +(* Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/closed/3346.v b/test-suite/bugs/closed/3346.v new file mode 100644 index 00000000..638404f2 --- /dev/null +++ b/test-suite/bugs/closed/3346.v @@ -0,0 +1,4 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +Monomorphic Inductive paths (A : Type) (a : A) : A -> Type := idpath : paths A a a. +(* This should fail with -indices-matter *) +Fail Check paths nat O O : Prop. diff --git a/test-suite/bugs/closed/3347.v b/test-suite/bugs/closed/3347.v new file mode 100644 index 00000000..37c0d87e --- /dev/null +++ b/test-suite/bugs/closed/3347.v @@ -0,0 +1,39 @@ +(* File reduced by coq-bug-finder from original input, then from 12653 lines to 12453 lines, then from 11673 lines to 681 lines, then from 693 lines to 469 lines, then from 375 lines to 56 lines *) +Set Universe Polymorphism. +Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Inductive Unit : Type1 := tt : Unit. +Fail Check Unit : Set. (* [Check Unit : Set] should fail if [Type1] is defined correctly *) +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Record Functor (C D : PreCategory) := { object_of :> C -> D }. +Definition indiscrete_category X : PreCategory := @Build_PreCategory X (fun _ _ => Unit). +Definition from_terminal (C : PreCategory) one (c : C) := Build_Functor one C (fun _ => c). +Local Notation "! x" := (from_terminal _ (indiscrete_category Unit) x) (at level 3). +Record NaturalTransformation {C D} (F G : Functor C D) := + { components_of :> forall c, morphism D (F c) (G c); + commutes : forall c, components_of c = components_of c }. +Definition slice_category_induced_functor_nt (D : PreCategory) s d (m : morphism D s d) +: NaturalTransformation !s !d. +Proof. + exists (fun _ : Unit => m); + simpl; intros; clear; + abstract admit. +Defined. +(* Toplevel input, characters 15-23: +Error: Illegal application: +The term "Build_NaturalTransformation" of type + "forall (C D : PreCategory) (F G : Functor C D) + (components_of : forall c : C, morphism D (F c) (G c)), + (forall c : C, components_of c = components_of c) -> + NaturalTransformation F G" +cannot be applied to the terms + "indiscrete_category Unit" : "PreCategory" + "D" : "PreCategory" + "! s" : "Functor (indiscrete_category Unit) D" + "! d" : "Functor (indiscrete_category Unit) D" + "fun _ : Unit => m" : "Unit -> morphism D s d" + "fun _ : Unit => slice_category_induced_functor_nt_subproof D s d m" + : "forall c : indiscrete_category Unit, m = m" +The 5th term has type "Unit -> morphism D s d" which should be coercible to + "forall c : indiscrete_category Unit, morphism D (! s c) (! d c)". + *) diff --git a/test-suite/bugs/closed/3348.v b/test-suite/bugs/closed/3348.v new file mode 100644 index 00000000..d9ac09d8 --- /dev/null +++ b/test-suite/bugs/closed/3348.v @@ -0,0 +1,6 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +Set Universe Polymorphism. +Set Printing Universes. +Inductive Empty : Set := . +(* Toplevel input, characters 15-41: +Error: Universe inconsistency. Cannot enforce Prop <= Set). *) diff --git a/test-suite/bugs/closed/335.v b/test-suite/bugs/closed/335.v new file mode 100644 index 00000000..166fa7a9 --- /dev/null +++ b/test-suite/bugs/closed/335.v @@ -0,0 +1,5 @@ +(* Compatibility of Require with backtracking at interactive module end *) + +Module A. +Require List. +End A. diff --git a/test-suite/bugs/closed/3350.v b/test-suite/bugs/closed/3350.v new file mode 100644 index 00000000..30fdf169 --- /dev/null +++ b/test-suite/bugs/closed/3350.v @@ -0,0 +1,120 @@ +Require Coq.Vectors.Fin. +Require Coq.Vectors.Vector. + +Local Generalizable All Variables. +Set Implicit Arguments. + +Arguments Fin.F1 : clear implicits. + +Lemma fin_0_absurd : notT (Fin.t 0). +Proof. hnf. apply Fin.case0. Qed. + +Axiom admit : forall {A}, A. + +Fixpoint lower {n:nat} (p:Fin.t (S n)) {struct p} : + forall (i:Fin.t (S n)), option (Fin.t n) + := match p in Fin.t (S n1) + return Fin.t (S n1) -> option (Fin.t n1) + with + | @Fin.F1 n1 => + fun (i:Fin.t (S n1)) => + match i in Fin.t (S n2) return option (Fin.t n2) with + | @Fin.F1 n2 => None + | @Fin.FS n2 i2 => Some i2 + end + | @Fin.FS n1 p1 => + fun (i:Fin.t (S n1)) => + match i in Fin.t (S n2) return Fin.t n2 -> option (Fin.t n2) with + | @Fin.F1 n2 => + match n2 as n3 return Fin.t n3 -> option (Fin.t n3) with + | 0 => fun p2 => False_rect _ (fin_0_absurd p2) + | S n3 => fun p2 => Some (Fin.F1 n3) + end + | @Fin.FS n2 i2 => + match n2 as n3 return Fin.t n3 -> Fin.t n3 -> option (Fin.t n3) with + | 0 => fun i3 p3 => False_rect _ (fin_0_absurd p3) + | S n3 => fun (i3 p3:Fin.t (S n3)) => + option_map (@Fin.FS _) admit + end i2 + end p1 + end. + +Lemma lower_ind (P: forall n (p i:Fin.t (S n)), option (Fin.t n) -> Prop) + (c11 : forall n, P n (Fin.F1 n) (Fin.F1 n) None) + (c1S : forall n (i:Fin.t n), P n (Fin.F1 n) (Fin.FS i) (Some i)) + (cS1 : forall n (p:Fin.t (S n)), + P (S n) (Fin.FS p) (Fin.F1 (S n)) (Some (Fin.F1 n))) + (cSSS : forall n (p i:Fin.t (S n)) (i':Fin.t n) + (Elow:lower p i = Some i'), + P n p i (Some i') -> + P (S n) (Fin.FS p) (Fin.FS i) (Some (Fin.FS i'))) + (cSSN : forall n (p i:Fin.t (S n)) + (Elow:lower p i = None), + P n p i None -> + P (S n) (Fin.FS p) (Fin.FS i) None) : + forall n (p i:Fin.t (S n)), P n p i (lower p i). +Proof. + fix 2. intros n p. + refine (match p as p1 in Fin.t (S n1) + return forall (i1:Fin.t (S n1)), P n1 p1 i1 (lower p1 i1) + with + | @Fin.F1 n1 => _ + | @Fin.FS n1 p1 => _ + end); clear n p. + { revert n1. refine (@Fin.caseS _ _ _); cbn; intros. + apply c11. apply c1S. } + { intros i1. revert p1. + pattern n1, i1; refine (@Fin.caseS _ _ _ _ _); + clear n1 i1; + (intros [|n] i; [refine (False_rect _ (fin_0_absurd i)) | cbn ]). + { apply cS1. } + { intros p. pose proof (admit : P n p i (lower p i)) as H. + destruct (lower p i) eqn:E. + { admit; assumption. } + { cbn. apply admit; assumption. } } } +Qed. + +Section squeeze. + Context {A:Type} (x:A). + Notation vec := (Vector.t A). + + Fixpoint squeeze {n} (v:vec n) (i:Fin.t (S n)) {struct i} : vec (S n) := + match i in Fin.t (S _n) return vec _n -> vec (S _n) + with + | @Fin.F1 n' => fun v' => Vector.cons _ x _ v' + | @Fin.FS n' i' => + fun v' => + match n' as _n return vec _n -> Fin.t _n -> vec (S _n) + with + | 0 => fun u i' => False_rect _ (fin_0_absurd i') + | S m => + fun (u:vec (S m)) => + match u in Vector.t _ (S _m) + return Fin.t (S _m) -> vec (S (S _m)) + with + | Vector.nil _ => tt + | Vector.cons _ h _ u' => + fun j' => Vector.cons _ h _ admit (* (squeeze u' j') *) + end + end v' i' + end v. +End squeeze. + +Require Import Program. +Lemma squeeze_nth (A:Type) (x:A) (n:nat) (v:Vector.t A n) p i : + Vector.nth (squeeze x v p) i = match lower p i with + | Some j => Vector.nth v j + | None => x + end. +Proof. + (* alternatively: [functional induction (lower p i) using lower_ind] *) + revert v. pattern n, p, i, (lower p i). + refine (@lower_ind _ _ _ _ _ _ n p i); + intros; cbn; auto. + + (*** Fails here with "Conversion test raised an anomaly" ***) + revert v. + admit. + admit. + admit. +Qed. diff --git a/test-suite/bugs/closed/3352.v b/test-suite/bugs/closed/3352.v new file mode 100644 index 00000000..b57b0a0f --- /dev/null +++ b/test-suite/bugs/closed/3352.v @@ -0,0 +1,34 @@ + +(* +I'm not sure what the general rule should be; intuitively, I want [IsHProp (* Set *) Foo] to mean [IsHProp (* U >= Set *) Foo]. (I think this worked in HoTT/coq, too.) Morally, [IsHProp] has no universe level associated with it distinct from that of its argument, you should never get a universe inconsistency from unifying [IsHProp A] with [IsHProp A]. (The issue is tricker when IsHProp uses [A] elsewhere, as in: +*) + +(* File reduced by coq-bug-finder from original input, then from 7725 lines to 78 lines, then from 51 lines to 13 lines *) +Set Universe Polymorphism. +Inductive Empty : Set := . +Record IsHProp (A : Type) := { foo : True }. +Definition hprop_Empty : IsHProp@{i} Empty := {| foo := I |}. +Goal let U := Type in let gt := Set : U in IsHProp (Empty : U). +simpl. +Set Printing Universes. +exact @hprop_Empty. (* Toplevel input, characters 21-32: +Error: +The term "hprop_Empty" has type "IsHProp (* Set *) Empty" +while it is expected to have type "IsHProp (* Top.17 *) Empty" +(Universe inconsistency: Cannot enforce Top.17 = Set because Set < Top.17)). *) +Defined. + +Module B. +(* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* File reduced by coq-bug-finder from original input, then from 7725 lines to 78 lines, then from 51 lines to 13 lines *) +Set Universe Polymorphism. +Inductive paths {A} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Record Contr (A : Type) := { center : A }. +Monomorphic Record IsHProp (A : Type) := { foo : forall x y : A, Contr (x = y) }. +Definition hprop_Empty : IsHProp Empty := {| foo x y := match x : Empty with end |}. +Goal let U := Type in let gt := Set : U in IsHProp (Empty : U). +simpl. +Set Printing Universes. +exact hprop_Empty. +Defined. +End B. \ No newline at end of file diff --git a/test-suite/bugs/closed/3354.v b/test-suite/bugs/closed/3354.v new file mode 100644 index 00000000..14b66db3 --- /dev/null +++ b/test-suite/bugs/closed/3354.v @@ -0,0 +1,12 @@ +Set Universe Polymorphism. +Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). +Inductive Empty : Type1 := . +Fail Check Empty : Set. +(* Toplevel input, characters 15-116: +Error: Conversion test raised an anomaly *) +(* Now we make sure it's not an anomaly *) +Goal True. +Proof. + try exact (let x := Empty : Set in I). + exact I. +Defined. diff --git a/test-suite/bugs/closed/3355.v b/test-suite/bugs/closed/3355.v new file mode 100644 index 00000000..46a57147 --- /dev/null +++ b/test-suite/bugs/closed/3355.v @@ -0,0 +1,6 @@ +Inductive paths {A} (x : A) : A -> Type := idpath : paths x x. +Goal forall A B : Set, @paths Type A B -> @paths Set A B. +Proof. + intros A B H. + Fail exact H. +Abort. diff --git a/test-suite/bugs/closed/3368.v b/test-suite/bugs/closed/3368.v new file mode 100644 index 00000000..1eff1dba --- /dev/null +++ b/test-suite/bugs/closed/3368.v @@ -0,0 +1,16 @@ +(* File reduced by coq-bug-finder from 7411 lines to 2271 lines., then from 889 lines to 119 lines, then from 76 lines to 19 lines *) +Set Universe Polymorphism. +Set Implicit Arguments. +Set Primitive Projections. +Record PreCategory := { object :> Type; morphism : object -> object -> Type }. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) }. +Definition opposite (C : PreCategory) : PreCategory := @Build_PreCategory C (fun s d => morphism C d s). +Definition opposite' C D (F : Functor C D) + := Build_Functor (opposite C) (opposite D) + (object_of F) + (fun s d => @morphism_of C D F d s). +(* Toplevel input, characters 15-191: +Anomaly: File "pretyping/reductionops.ml", line 149, characters 4-10: Assertion failed. +Please report. *) diff --git a/test-suite/bugs/closed/3372.v b/test-suite/bugs/closed/3372.v new file mode 100644 index 00000000..91e3df76 --- /dev/null +++ b/test-suite/bugs/closed/3372.v @@ -0,0 +1,7 @@ +Set Universe Polymorphism. +Definition hProp : Type := sigT (fun _ : Type => True). +Goal Type. +Fail exact hProp@{Set}. (* test that it fails, but is not an anomaly *) +try (exact hProp@{Set}; fail 1). (* Toplevel input, characters 15-32: +Anomaly: Uncaught exception Invalid_argument("Array.iter2", _). +Please report. *) diff --git a/test-suite/bugs/closed/3373.v b/test-suite/bugs/closed/3373.v new file mode 100644 index 00000000..5ecf2801 --- /dev/null +++ b/test-suite/bugs/closed/3373.v @@ -0,0 +1,33 @@ +(* File reduced by coq-bug-finder from original input, then from 5968 lines to +11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 +lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then +from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 +lines to 320 lines, then from 328 lines to 302 lines, then from 332 lines to 21 +lines *) +Set Universe Polymorphism. +Module short. + Record foo := { bar : Type }. + Coercion baz (x : foo@{Set}) : Set := bar x. + Goal True. + Proof. + Fail pose ({| bar := Set |} : Type). (* check that it fails *) + try pose ({| bar := Set |} : Type). (* Anomaly: apply_coercion_args: mismatch between arguments and coercion. +Please report. *) + Admitted. +End short. + +Module long. + Axiom admit : forall {T}, T. + Definition UU := Set. + Definition UU' := Type. + Definition hSet:= sigT (fun X : UU' => admit) . + Definition pr1hSet:= @projT1 UU (fun X : UU' => admit) : hSet -> Type. + Coercion pr1hSet: hSet >-> Sortclass. + Axiom binop : UU -> Type. + Axiom setwithbinop : Type. + Goal True. + Proof. + Fail pose (( @projT1 _ ( fun X : hSet@{i j k} => binop X ) ) : _ -> hSet). (* check that it fails *) + try pose (( @projT1 _ ( fun X : hSet@{i j k} => binop X ) ) : _ -> hSet). (* check that it's not an anomaly *) + Admitted. +End long. diff --git a/test-suite/bugs/closed/3374.v b/test-suite/bugs/closed/3374.v new file mode 100644 index 00000000..3c67703a --- /dev/null +++ b/test-suite/bugs/closed/3374.v @@ -0,0 +1,51 @@ +(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines, then from 331 lines to 59 lines *) + +Set Universe Polymorphism. +Axiom admit : forall {T}, T. +Notation paths := identity . +Definition UU := Set. +Definition dirprod ( X Y : UU ) := sigT ( fun x : X => Y ) . +Definition dirprodpair { X Y : UU } := existT ( fun x : X => Y ) . +Definition hProp := sigT (fun X : Type => admit). +Definition hProptoType := @projT1 _ _ : hProp -> Type . +Coercion hProptoType: hProp >-> Sortclass. +Definition UU' := Type. +Definition hSet:= sigT (fun X : UU' => admit) . +Definition pr1hSet:= @projT1 UU (fun X : UU' => admit) : hSet -> Type. +Coercion pr1hSet: hSet >-> Sortclass. +Axiom hsubtypes : UU -> Type. +Definition hrel ( X : UU ) := X -> X -> hProp. +Axiom hreldirprod : forall { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ), hrel ( dirprod X Y ) . +Axiom iseqclass : forall { X : UU } ( R : hrel X ) ( A : hsubtypes X ), Type. +Definition setquot { X : UU } ( R : hrel X ) : Type := sigT (fun A => iseqclass R A). +Axiom dirprodtosetquot : forall { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot RX ) ( setquot RY ) ), + setquot ( hreldirprod RX RY ). +Definition iscomprelfun2 { X Y : UU } ( R : hrel X ) ( f : X -> X -> Y ) + := forall x x' x0 x0' : X , R x x' -> R x0 x0' -> paths ( f x x0 ) ( f x' x0' ) . +Axiom setquotuniv : forall { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> Y ) ( c : setquot R ), Y . +Definition setquotuniv2 { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> X -> Y ) ( is : iscomprelfun2 R f ) ( c c0 : setquot R ) +: Y . +Proof. + intros . + set ( RR := hreldirprod R R ) . + apply (setquotuniv RR Y admit). + apply (dirprodtosetquot R R). + apply dirprodpair; [ exact c | exact c0 ]. + Undo. + exact (dirprodpair c c0). +Defined. + (* Toplevel input, characters 39-40: +Error: +In environment +X : UU +R : hrel X +Y : hSet +f : X -> X -> Y +is : iscomprelfun2 R f +c : setquot R +c0 : setquot R +RR := hreldirprod R R : hrel (dirprod X X) +The term "c" has type "setquot R" while it is expected to have type +"?42" (unable to find a well-typed instantiation for +"?42": cannot unify"Type" and "UU"). + *) diff --git a/test-suite/bugs/closed/3375.v b/test-suite/bugs/closed/3375.v new file mode 100644 index 00000000..fe323fcb --- /dev/null +++ b/test-suite/bugs/closed/3375.v @@ -0,0 +1,48 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-impredicative-set") -*- *) +(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines, then from 330 lines to 45 lines *) + +Set Universe Polymorphism. +Axiom admit : forall {T}, T. +Definition UU := Set. +Definition dirprod ( X Y : UU ) := sigT ( fun x : X => Y ) . +Definition dirprodpair { X Y : UU } := existT ( fun x : X => Y ) . +Definition hProp := sigT (fun X : Type => admit). +Axiom hProppair : forall ( X : UU ) ( is : admit ), hProp. +Definition hProptoType := @projT1 _ _ : hProp -> Type . +Coercion hProptoType: hProp >-> Sortclass. +Definition ishinh_UU ( X : UU ) : UU := forall P: Set, ( ( X -> P ) -> P ). +Definition ishinh ( X : UU ) : hProp := hProppair ( ishinh_UU X ) admit. +Definition hsubtypes ( X : UU ) : Type := X -> hProp. +Axiom carrier : forall { X : UU } ( A : hsubtypes X ), Type. +Definition hrel ( X : UU ) : Type := X -> X -> hProp. +Set Printing Universes. +Definition iseqclass { X : UU } ( R : hrel X ) ( A : hsubtypes X ) : Type. + intros; exact ( dirprod ( ishinh ( carrier A ) ) ( dirprod ( forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) + ( forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) )) . +Defined. +Definition iseqclassconstr' { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) ) + ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) : iseqclass R A. + intros. + apply dirprodpair. { exact ax0. } + apply dirprodpair. { exact ax1. } {exact ax2. } +Defined. +Definition iseqclassconstr { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) ) + ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) : iseqclass R A. + pose @iseqclassconstr'. + intros. + exact (dirprodpair ax0 (dirprodpair ax1 ax2)). +Defined. +(* Toplevel input, characters 15-23: +Error: Illegal application: +The term "dirprodpair" of type + "forall (X Y : UU) (x : X), (fun _ : X => Y) x -> {_ : X & Y}" +cannot be applied to the terms + "forall x1 x2 : X, R x1 x2 -> A x1 -> A x2" + : "Type@{max(Set, Top.476, Top.479)}" + "forall x1 x2 : X, A x1 -> A x2 -> R x1 x2" + : "Type@{max(Set, Top.476, Top.479)}" + "ax1" : "forall x1 x2 : X, R x1 x2 -> A x1 -> A x2" + "ax2" : "forall x1 x2 : X, A x1 -> A x2 -> R x1 x2" +The 1st term has type "Type@{max(Set, Top.476, Top.479)}" +which should be coercible to "UU". + *) diff --git a/test-suite/bugs/closed/3377.v b/test-suite/bugs/closed/3377.v new file mode 100644 index 00000000..8e9e3933 --- /dev/null +++ b/test-suite/bugs/closed/3377.v @@ -0,0 +1,17 @@ +Set Primitive Projections. +Set Implicit Arguments. +Record prod A B := pair { fst : A; snd : B}. + +Goal fst (@pair Type Type Type Type). +Set Printing All. +match goal with |- ?f ?x => set (foo := f x) end. + +Goal forall x : prod Set Set, x = @pair _ _ (fst x) (snd x). +Proof. + intro x. + lazymatch goal with + | [ |- ?x = @pair _ _ (?f ?x) (?g ?x) ] => pose f + end. + +(* Toplevel input, characters 7-44: +Error: No matching clauses for match. *) diff --git a/test-suite/bugs/closed/3382.v b/test-suite/bugs/closed/3382.v new file mode 100644 index 00000000..1d8e9167 --- /dev/null +++ b/test-suite/bugs/closed/3382.v @@ -0,0 +1,63 @@ +(* File reduced by coq-bug-finder from 9039 lines to 7786 lines, then from 7245 lines to 476 lines, then from 417 lines to 249 lines, then from 171 lines to 127 lines, then from 139 lines to 114 lines, then from 93 lines to 77 lines *) + +Set Implicit Arguments. +Definition admit {T} : T. +Admitted. +Delimit Scope object_scope with object. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope functor_scope with functor. +Reserved Infix "o" (at level 40, left associativity). +Record PreCategory := + { Object :> Type; + Morphism : Object -> Object -> Type; + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' where "f 'o' g" := (Compose f g) }. +Bind Scope category_scope with PreCategory. +Infix "o" := (@Compose _ _ _ _) : morphism_scope. +Local Open Scope morphism_scope. +Record Functor (C D : PreCategory) := + { ObjectOf :> C -> D; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d); + FCompositionOf : forall s d d' (m1 : C.(Morphism) s d) (m2: C.(Morphism) d d'), + MorphismOf _ _ (m2 o m1) = (MorphismOf _ _ m2) o (MorphismOf _ _ m1) }. +Bind Scope functor_scope with Functor. +Arguments MorphismOf [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. +Definition ComposeFunctors C D E + (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor C E (fun c => G (F c)) admit admit. +Infix "o" := ComposeFunctors : functor_scope. +Record NaturalTransformation C D (F G : Functor C D) := + { ComponentsOf :> forall c, D.(Morphism) (F c) (G c); + Commutes : forall s d (m : C.(Morphism) s d), + ComponentsOf d o F.(MorphismOf) m = G.(MorphismOf) m o ComponentsOf s }. +Definition NTComposeT C D (F F' F'' : Functor C D) + (T' : NaturalTransformation F' F'') + (T : NaturalTransformation F F') + (CO := fun c => T' c o T c) +: NaturalTransformation F F''. + exact (Build_NaturalTransformation F F'' + (fun c => T' c o T c) + (admit : forall s d (m : Morphism C s d), CO d o MorphismOf F m = MorphismOf F'' m o CO s)). +Defined. +Definition NTWhiskerR C D E (F F' : Functor D E) (T : NaturalTransformation F F') + (G : Functor C D) + := Build_NaturalTransformation (F o G) (F' o G) (fun c => T (G c)) admit. +Axiom NTWhiskerR_CompositionOf +: forall C D + (F G H : Functor C D) + (T : NaturalTransformation G H) + (T' : NaturalTransformation F G) B (I : Functor B C), + NTComposeT (NTWhiskerR T I) (NTWhiskerR T' I) = NTWhiskerR (NTComposeT T T') I. +Definition FunctorCategory C D : PreCategory + := @Build_PreCategory (Functor C D) + (NaturalTransformation (C := C) (D := D)) + admit. +Notation "[ C , D ]" := (FunctorCategory C D) : category_scope. +Class silly {T} := term : T. +Timeout 1 Fail Definition NTWhiskerR_Functorial (C D E : PreCategory) (G : [C, D]%category) +: [[D, E], [C, E]]%category + := Build_Functor + [C, D] [C, E] + (fun F => _ : silly) + (fun _ _ T => _ : silly) + (fun _ _ _ _ _ => NTWhiskerR_CompositionOf _ _ _). diff --git a/test-suite/bugs/closed/3386.v b/test-suite/bugs/closed/3386.v new file mode 100644 index 00000000..0e236c21 --- /dev/null +++ b/test-suite/bugs/closed/3386.v @@ -0,0 +1,16 @@ +Set Universe Polymorphism. +Set Printing Universes. +Record Cat := { Obj :> Type }. +Definition set_cat := {| Obj := Type |}. +Goal Type@{i} = Type@{j}. +Proof. + (* 1 subgoals +, subgoal 1 (ID 3) + + ============================ + Type@{Top.368} = Type@{Top.370} +(dependent evars:) *) + Fail change Type@{i} with (Obj set_cat@{i}). (* check that it fails *) + try change Type@{i} with (Obj set_cat@{i}). (* check that it's not an anomaly *) +(* Anomaly: Uncaught exception Invalid_argument("Array.iter2", _). +Please report. *) diff --git a/test-suite/bugs/closed/3387.v b/test-suite/bugs/closed/3387.v new file mode 100644 index 00000000..ae212caa --- /dev/null +++ b/test-suite/bugs/closed/3387.v @@ -0,0 +1,21 @@ +Set Universe Polymorphism. +Set Printing Universes. +Record Cat := { Obj :> Type }. +Definition set_cat := {| Obj := Type |}. +Goal Type@{i} = Type@{j}. +Proof. + (* 1 subgoals +, subgoal 1 (ID 3) + + ============================ + Type@{Top.368} = Type@{Top.370} +(dependent evars:) *) + let x := constr:(Type) in + let y := constr:(Obj set_cat) in + unify x y. (* success *) + let x := constr:(Type) in + let y := constr:(Obj set_cat) in + first [ unify x y | fail 2 "no unify" ]; + change x with y at -1. (* Error: Not convertible. *) + reflexivity. +Defined. \ No newline at end of file diff --git a/test-suite/bugs/closed/3388.v b/test-suite/bugs/closed/3388.v new file mode 100644 index 00000000..78262804 --- /dev/null +++ b/test-suite/bugs/closed/3388.v @@ -0,0 +1,57 @@ +Inductive test : bool -> bool -> Type := +| test00 : test false false +| test01 : test false true +| test10 : test true false +. + +(* This does not work *) +Definition test_a (t : test true false) : test true false := + match t with + | test10 => test10 + end. + +(* The following definition shows that test_a SHOULD work *) +Definition test_a_workaround (t : test true false) : test true false := + match t with + | test10 => test10 + | _ => tt + end. + +(* Surprisingly, this works *) +Definition test_b (t : test false true) : test false true := + match t with + | test01 => test01 + end. + + +(* This, too, works *) +Definition test_c x (t : test false x) : test false x := + match t with + | test00 => test00 + | test01 => test01 + end. + +Inductive test2 : bool -> bool -> Type := +| test201 : test2 false true +| test210 : test2 true false +| test211 : test2 true true +. + +(* Now this works *) +Definition test2_a (t : test2 true false) : test2 true false := + match t with + | test210 => test210 + end. + +(* Accordingly, this now fails *) +Definition test2_b (t : test2 false true) : test2 false true := + match t with + | test201 => test201 + end. + + +(* This, too, fails *) +Definition test2_c x (t : test2 false x) : test2 false x := + match t with + | test201 => test201 + end. diff --git a/test-suite/bugs/closed/3390.v b/test-suite/bugs/closed/3390.v new file mode 100644 index 00000000..eb3c4f4b --- /dev/null +++ b/test-suite/bugs/closed/3390.v @@ -0,0 +1,9 @@ +Tactic Notation "basicapply" open_constr(R) "using" tactic3(tac) "sideconditions" tactic0(tacfin) := idtac. +Tactic Notation "basicapply" open_constr(R) := basicapply R using (fun Hlem => idtac) sideconditions (autounfold with spred; idtac). +(* segfault in coqtop *) + + +Tactic Notation "basicapply" tactic0(tacfin) := idtac. + +Goal True. +basicapply subst. diff --git a/test-suite/bugs/closed/3392.v b/test-suite/bugs/closed/3392.v new file mode 100644 index 00000000..29ee1487 --- /dev/null +++ b/test-suite/bugs/closed/3392.v @@ -0,0 +1,40 @@ +(* File reduced by coq-bug-finder from original input, then from 12105 lines to 142 lines, then from 83 lines to 57 lines *) +Generalizable All Variables. +Axiom admit : forall {T}, T. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end. +Definition apD {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y): transport _ p (f x) = f y := admit. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) }. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3). +Axiom path_forall : forall {A : Type} {P : A -> Type} (f g : forall x : A, P x), (forall x, f x = g x) -> f = g. +Axiom isequiv_adjointify : forall {A B} (f : A -> B) (g : B -> A) (isretr : Sect g f) (issect : Sect f g), IsEquiv f. +Definition functor_forall `{P : A -> Type} `{Q : B -> Type} (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) +: (forall a:A, P a) -> (forall b:B, Q b) := (fun g b => f1 _ (g (f0 b))). +Goal forall `{P : A -> Type} `{Q : B -> Type} `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)}, + IsEquiv (functor_forall f g). +Proof. + intros. + refine (isequiv_adjointify (functor_forall f g) + (functor_forall (f^-1) + (fun (x:A) (y:Q (f^-1 x)) => @eisretr _ _ f _ x # (g (f^-1 x))^-1 y + )) _ _); + intros h. + - abstract ( + apply path_forall; intros b; unfold functor_forall; + rewrite eisadj; + admit + ). + - abstract ( + apply path_forall; intros a; unfold functor_forall; + rewrite eissect; + apply apD + ). +Defined. diff --git a/test-suite/bugs/closed/3393.v b/test-suite/bugs/closed/3393.v new file mode 100644 index 00000000..ec25e682 --- /dev/null +++ b/test-suite/bugs/closed/3393.v @@ -0,0 +1,152 @@ +(* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* File reduced by coq-bug-finder from original input, then from 8760 lines to 7519 lines, then from 7050 lines to 909 lines, then from 846 lines to 578 lines, then from 497 lines to 392 lines, then from 365 lines to 322 lines, then from 252 lines to 205 lines, then from 215 lines to 204 lines, then from 210 lines to 182 lines, then from 175 lines to 157 lines *) +Set Universe Polymorphism. +Axiom admit : forall {T}, T. +Set Implicit Arguments. +Generalizable All Variables. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "a = b" := (@paths _ a b) : type_scope. +Arguments idpath {A a} , [A] a. +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) : forall x, f x = g x := fun x => match h with idpath => idpath end. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }. +Delimit Scope equiv_scope with equiv. +Local Open Scope equiv_scope. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. +Class Funext := { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. +Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : (forall x, f x = g x) -> f = g := (@apD10 A P f g)^-1. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' where "f 'o' g" := (compose f g); + associativity : forall x1 x2 x3 x4 (m1 : morphism x1 x2) (m2 : morphism x2 x3) (m3 : morphism x3 x4), (m3 o m2) o m1 = m3 o (m2 o m1) + }. +Bind Scope category_scope with PreCategory. +Bind Scope morphism_scope with morphism. +Infix "o" := (@compose _ _ _ _) : morphism_scope. +Delimit Scope functor_scope with functor. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) }. +Bind Scope functor_scope with Functor. +Notation "F '_1' m" := (@morphism_of _ _ F _ _ m) (at level 10, no associativity) : morphism_scope. +Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }. +Local Notation "m ^-1" := (morphism_inverse (m := m)) : morphism_scope. +Class Isomorphic {C : PreCategory} s d := + { morphism_isomorphic :> morphism C s d; + isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic }. +Coercion morphism_isomorphic : Isomorphic >-> morphism. +Definition isisomorphism_inverse `(@IsIsomorphism C x y m) : IsIsomorphism m^-1 := {| morphism_inverse := m |}. + +Global Instance isisomorphism_compose `(@IsIsomorphism C y z m0) `(@IsIsomorphism C x y m1) : IsIsomorphism (m0 o m1). +Admitted. +Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope. +Definition composef C D E (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => @morphism_of _ _ G _ _ (@morphism_of _ _ F _ _ m)). +Infix "o" := composef : functor_scope. +Delimit Scope natural_transformation_scope with natural_transformation. + +Local Open Scope morphism_scope. +Record NaturalTransformation C D (F G : Functor C D) := + { components_of :> forall c, morphism D (F c) (G c); + commutes : forall s d (m : morphism C s d), components_of d o F _1 m = G _1 m o components_of s }. + +Definition composet C D (F F' F'' : Functor C D) (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F') +: NaturalTransformation F F'' + := Build_NaturalTransformation F F'' (fun c => T' c o T c) admit. +Infix "o" := composet : natural_transformation_scope. +Section path_natural_transformation. + Context `{Funext}. + Variable C : PreCategory. + Variable D : PreCategory. + Variables F G : Functor C D. + Section path. + Variables T U : NaturalTransformation F G. + Lemma path'_natural_transformation + : components_of T = components_of U + -> T = U. + admit. + Defined. + Lemma path_natural_transformation + : (forall x, components_of T x = components_of U x) + -> T = U. + Proof. + intros. + apply path'_natural_transformation. + apply path_forall; assumption. + Qed. + End path. +End path_natural_transformation. +Ltac path_natural_transformation := + repeat match goal with + | _ => intro + | _ => apply path_natural_transformation; simpl + end. + +Local Open Scope natural_transformation_scope. +Definition associativityt `{fs : Funext} + C D F G H I + (V : @NaturalTransformation C D F G) + (U : @NaturalTransformation C D G H) + (T : @NaturalTransformation C D H I) +: (T o U) o V = T o (U o V). +Proof. + path_natural_transformation. + apply associativity. +Qed. +Definition functor_category `{Funext} (C D : PreCategory) : PreCategory + := @Build_PreCategory (Functor C D) (@NaturalTransformation C D) (@composet C D) (@associativityt _ C D). +Notation "C -> D" := (functor_category C D) : category_scope. +Definition NaturalIsomorphism `{Funext} (C D : PreCategory) F G := @Isomorphic (C -> D) F G. +Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope. +Global Instance isisomorphism_compose' `{Funext} + `(T' : @NaturalTransformation C D F' F'') + `(T : @NaturalTransformation C D F F') + `{@IsIsomorphism (C -> D) F' F'' T'} + `{@IsIsomorphism (C -> D) F F' T} +: @IsIsomorphism (C -> D) F F'' (T' o T)%natural_transformation + := @isisomorphism_compose (C -> D) _ _ T' _ _ T _. +Section lemmas. + Context `{Funext}. + Variable C : PreCategory. + Variable F : C -> PreCategory. + Context + {w y z} + {f : Functor (F w) (F z)} {f0 : Functor (F w) (F y)} + {f2 : Functor (F y) (F z)} + {f5 : Functor (F w) (F z)} + {n2 : f <~=~> (f2 o f0)%functor}. + Lemma p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper' XX + : @IsIsomorphism + (F w -> F z) f5 f + (n2 ^-1 o XX)%natural_transformation. + Proof. + eapply isisomorphism_compose'. + eapply isisomorphism_inverse. (* Toplevel input, characters 22-43: +Error: +In environment +H : Funext +C : PreCategory +F : C -> PreCategory +w : C +y : C +z : C +f : Functor (F w) (F z) +f0 : Functor (F w) (F y) +f2 : Functor (F y) (F z) +f5 : Functor (F w) (F z) +n2 : f <~=~> (f2 o f0)%functor +XX : NaturalTransformation f5 (f2 o f0) +Unable to unify + "{| + object := Functor (F w) (F z); + morphism := NaturalTransformation (D:=F z); + compose := composet (D:=F z); + associativity := associativityt (D:=F z) |}" with + "{| + object := Functor (F w) (F z); + morphism := NaturalTransformation (D:=F z); + compose := composet (D:=F z); + associativity := associativityt (D:=F z) |}". *) diff --git a/test-suite/bugs/closed/3402.v b/test-suite/bugs/closed/3402.v new file mode 100644 index 00000000..ed47ec82 --- /dev/null +++ b/test-suite/bugs/closed/3402.v @@ -0,0 +1,7 @@ +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. +Goal forall A B (p : prod A B), p = let (x, y) := p in pair A B x y. +Proof. + intros A B p. + exact eq_refl. +Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/3408.v b/test-suite/bugs/closed/3408.v new file mode 100644 index 00000000..b12b8c1a --- /dev/null +++ b/test-suite/bugs/closed/3408.v @@ -0,0 +1,163 @@ +Require Import BinPos. + +Inductive expr : Type := + Var : nat -> expr +| App : expr -> expr -> expr +| Abs : unit -> expr -> expr. + +Inductive expr_acc +: expr -> expr -> Prop := + acc_App_l : forall f a : expr, + expr_acc f (App f a) +| acc_App_r : forall f a : expr, + expr_acc a (App f a) +| acc_Abs : forall (t : unit) (e : expr), + expr_acc e (Abs t e). + +Theorem wf_expr_acc : well_founded expr_acc. +Proof. + red. + refine (fix rec a : Acc expr_acc a := + match a as a return Acc expr_acc a with + | Var v => Acc_intro _ (fun y (_H : expr_acc y (Var v)) => + match _H in expr_acc z Z + return match Z return Prop with + | Var _ => Acc _ y + | _ => True + end + with + | acc_App_l _ _ => I + | _ => I + end) + | App f x => Acc_intro _ (fun y (pf : expr_acc y (App f x)) => + match pf in expr_acc z Z + return match Z return Prop with + | App a b => f = a -> x = b -> Acc expr_acc z + | _ => True + end + with + | acc_App_l f' x' => fun pf _ => match pf in _ = z return + Acc expr_acc z + with + | eq_refl => rec f + end + | acc_App_r f' x' => fun _ pf => match pf in _ = z return + Acc expr_acc z + with + | eq_refl => rec x + end + | _ => I + end eq_refl eq_refl) + | Abs t e => Acc_intro _ (fun y (pf : expr_acc y (Abs t e)) => + match pf in expr_acc z Z + return match Z return Prop with + | Abs a b => e = b -> Acc expr_acc z + | _ => True + end + with + | acc_Abs f x => fun pf => match pf in _ = z return + Acc expr_acc z + with + | eq_refl => rec e + end + | _ => I + end eq_refl) + end). +Defined. + +Theorem wf_expr_acc_delay : well_founded expr_acc. +Proof. + red. + refine (fix rec a : Acc expr_acc a := + match a as a return Acc expr_acc a with + | Var v => Acc_intro _ (fun y (_H : expr_acc y (Var v)) => + match _H in expr_acc z Z + return match Z return Prop with + | Var _ => Acc _ y + | _ => True + end + with + | acc_App_l _ _ => I + | _ => I + end) + | App f x => Acc_intro _ (fun y (pf : expr_acc y (App f x)) => + match pf in expr_acc z Z + return match Z return Prop with + | App a b => (unit -> Acc expr_acc a) -> (unit -> Acc expr_acc b) -> Acc expr_acc z + | _ => True + end + with + | acc_App_l f' x' => fun pf _ => pf tt + | acc_App_r f' x' => fun _ pf => pf tt + | _ => I + end (fun _ => rec f) (fun _ => rec x)) + | Abs t e => Acc_intro _ (fun y (pf : expr_acc y (Abs t e)) => + match pf in expr_acc z Z + return match Z return Prop with + | Abs a b => (unit -> Acc expr_acc b) -> Acc expr_acc z + | _ => True + end + with + | acc_Abs f x => fun pf => pf tt + | _ => I + end (fun _ => rec e)) + end); + try solve [ inversion _H ]. +Defined. + +Fixpoint build_large (n : nat) : expr := + match n with + | 0 => Var 0 + | S n => + let e := build_large n in + App e e + end. + +Section guard. + Context {A : Type} {R : A -> A -> Prop}. + + Fixpoint guard (n : nat) (wfR : well_founded R) : well_founded R := + match n with + | 0 => wfR + | S n0 => + fun x : A => + Acc_intro x + (fun (y : A) (_ : R y x) => guard n0 (guard n0 wfR) y) + end. +End guard. + + +Definition sizeF_delay : expr -> positive. +refine + (@Fix expr (expr_acc) + (wf_expr_acc_delay) + (fun _ => positive) + (fun e => + match e as e return (forall l, expr_acc l e -> positive) -> positive with + | Var _ => fun _ => 1 + | App l r => fun rec => @rec l _ + @rec r _ + | Abs _ e => fun rec => 1 + @rec e _ + end%positive)). +eapply acc_App_l. +eapply acc_App_r. +eapply acc_Abs. +Defined. + +Definition sizeF_guard : expr -> positive. +refine + (@Fix expr (expr_acc) + (guard 5 wf_expr_acc) + (fun _ => positive) + (fun e => + match e as e return (forall l, expr_acc l e -> positive) -> positive with + | Var _ => fun _ => 1 + | App l r => fun rec => @rec l _ + @rec r _ + | Abs _ e => fun rec => 1 + @rec e _ + end%positive)). +eapply acc_App_l. +eapply acc_App_r. +eapply acc_Abs. +Defined. + +Time Eval native_compute in sizeF_delay (build_large 2). +Time Eval native_compute in sizeF_guard (build_large 2). diff --git a/test-suite/bugs/closed/3416.v b/test-suite/bugs/closed/3416.v new file mode 100644 index 00000000..5cfb8f1f --- /dev/null +++ b/test-suite/bugs/closed/3416.v @@ -0,0 +1,12 @@ +Inductive list A := Node : node A -> list A +with node A := Nil | Cons : A -> list A -> node A. + +Fixpoint app {A} (l1 l2 : list A) {struct l1} : list A +with app_node {A} (n1 : node A) (l2 : list A) {struct n1} : node A. +Proof. ++ destruct l1 as [n]; constructor. + exact (app_node _ n l2). ++ destruct n1 as [|x l1]. + - destruct l2 as [n2]; exact n2. + - exact (Cons _ x (app _ l1 l2)). +Qed. diff --git a/test-suite/bugs/closed/3417.v b/test-suite/bugs/closed/3417.v new file mode 100644 index 00000000..9d7c6f01 --- /dev/null +++ b/test-suite/bugs/closed/3417.v @@ -0,0 +1,7 @@ +Require Setoid. + +Goal forall {T}(a b : T), b=a -> {c | c=b}. +Proof. +intros T a b H. +try setoid_rewrite H. +Abort. diff --git a/test-suite/bugs/closed/3422.v b/test-suite/bugs/closed/3422.v new file mode 100644 index 00000000..d984f623 --- /dev/null +++ b/test-suite/bugs/closed/3422.v @@ -0,0 +1,208 @@ +Generalizable All Variables. +Set Implicit Arguments. +Set Universe Polymorphism. +Axiom admit : forall {T}, T. +Reserved Infix "o" (at level 40, left associativity). +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }. +Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Existing Instance equiv_isequiv. +Delimit Scope equiv_scope with equiv. +Local Open Scope equiv_scope. +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. +Axiom IsHSet : Type -> Type. +Existing Class IsHSet. +Definition trunc_equiv' `(f : A <~> B) `{IsHSet A} : IsHSet B := admit. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + trunc_morphism : forall s d, IsHSet (morphism s d) }. + +Bind Scope category_scope with PreCategory. +Infix "o" := (@compose _ _ _ _) : morphism_scope. + +Delimit Scope functor_scope with functor. + +Record Functor (C D : PreCategory) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d) + }. + +Bind Scope functor_scope with Functor. +Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. +Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. +Local Open Scope morphism_scope. + +Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }. + +Local Notation "m ^-1" := (morphism_inverse (m := m)) : morphism_scope. + +Class Isomorphic {C : PreCategory} s d := + { + morphism_isomorphic :> morphism C s d; + isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic + }. + +Coercion morphism_isomorphic : Isomorphic >-> morphism. + +Local Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope. + +Definition isisomorphism_inverse `(@IsIsomorphism C x y m) : IsIsomorphism m^-1 := {| morphism_inverse := m |}. + +Global Instance isisomorphism_compose `(@IsIsomorphism C y z m0) `(@IsIsomorphism C x y m1) +: IsIsomorphism (m0 o m1). +admit. +Defined. + +Section composition. + Variable C : PreCategory. + Variable D : PreCategory. + Variable E : PreCategory. + Variable G : Functor D E. + Variable F : Functor C D. + + Definition composeF : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => morphism_of G (morphism_of F m)). +End composition. +Infix "o" := composeF : functor_scope. + +Delimit Scope natural_transformation_scope with natural_transformation. +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. + +Section compose. + Variable C : PreCategory. + Variable D : PreCategory. + Variables F F' F'' : Functor C D. + + Variable T' : NaturalTransformation F' F''. + Variable T : NaturalTransformation F F'. + + Local Notation CO c := (T' c o T c). + + Definition composeT + : NaturalTransformation F F'' := Build_NaturalTransformation F F'' (fun c => CO c). + +End compose. + +Section whisker. + Variable C : PreCategory. + Variable D : PreCategory. + Variable E : PreCategory. + + Section L. + Variable F : Functor D E. + Variables G G' : Functor C D. + Variable T : NaturalTransformation G G'. + + Local Notation CO c := (morphism_of F (T c)). + + Definition whisker_l + := Build_NaturalTransformation + (F o G) (F o G') + (fun c => CO c). + + End L. + + Section R. + Variables F F' : Functor D E. + Variable T : NaturalTransformation F F'. + Variable G : Functor C D. + + Local Notation CO c := (T (G c)). + + Definition whisker_r + := Build_NaturalTransformation + (F o G) (F' o G) + (fun c => CO c). + End R. +End whisker. +Infix "o" := composeT : natural_transformation_scope. +Infix "oL" := whisker_l (at level 40, left associativity) : natural_transformation_scope. +Infix "oR" := whisker_r (at level 40, left associativity) : natural_transformation_scope. + +Section path_natural_transformation. + + Variable C : PreCategory. + Variable D : PreCategory. + Variables F G : Functor C D. + + Lemma equiv_sig_natural_transformation + : { CO : forall x, morphism D (F x) (G x) + | forall s d (m : morphism C s d), + CO d o F _1 m = G _1 m o CO s } + <~> NaturalTransformation F G. + admit. + Defined. + + Global Instance trunc_natural_transformation + : IsHSet (NaturalTransformation F G). + Proof. + eapply trunc_equiv'; [ exact equiv_sig_natural_transformation | ]. + admit. + Qed. + +End path_natural_transformation. +Definition functor_category (C D : PreCategory) : PreCategory + := @Build_PreCategory (Functor C D) (@NaturalTransformation C D) (@composeT C D) _. + +Notation "C -> D" := (functor_category C D) : category_scope. + +Definition NaturalIsomorphism (C D : PreCategory) F G := @Isomorphic (C -> D) F G. + +Coercion natural_transformation_of_natural_isomorphism C D F G (T : @NaturalIsomorphism C D F G) : NaturalTransformation F G + := T : morphism _ _ _. +Local Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope. +Global Instance isisomorphism_compose' + `(T' : @NaturalTransformation C D F' F'') + `(T : @NaturalTransformation C D F F') + `{@IsIsomorphism (C -> D) F' F'' T'} + `{@IsIsomorphism (C -> D) F F' T} +: @IsIsomorphism (C -> D) F F'' (T' o T)%natural_transformation + := @isisomorphism_compose (C -> D) _ _ T' _ _ T _. + +Section lemmas. + Local Open Scope natural_transformation_scope. + + Variable C : PreCategory. + Variable F : C -> PreCategory. + Context + {w x y z} + {f : Functor (F w) (F z)} {f0 : Functor (F w) (F y)} + {f1 : Functor (F x) (F y)} {f2 : Functor (F y) (F z)} + {f3 : Functor (F w) (F x)} {f4 : Functor (F x) (F z)} + {f5 : Functor (F w) (F z)} {n : f5 <~=~> (f4 o f3)%functor} + {n0 : f4 <~=~> (f2 o f1)%functor} {n1 : f0 <~=~> (f1 o f3)%functor} + {n2 : f <~=~> (f2 o f0)%functor}. + + Lemma p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper' + : @IsIsomorphism + (_ -> _) _ _ + (n2 ^-1 o (f2 oL n1 ^-1 o (admit o (n0 oR f3 o n))))%natural_transformation. + Proof. + eapply isisomorphism_compose'; + [ eapply isisomorphism_inverse + | eapply isisomorphism_compose'; + [ admit + | eapply isisomorphism_compose'; + [ admit | + eapply isisomorphism_compose'; [ admit | ]]]]. + Set Printing All. Set Printing Universes. + apply @isisomorphism_isomorphic. + Qed. + +End lemmas. diff --git a/test-suite/bugs/closed/3424.v b/test-suite/bugs/closed/3424.v new file mode 100644 index 00000000..f9b2c386 --- /dev/null +++ b/test-suite/bugs/closed/3424.v @@ -0,0 +1,23 @@ +Set Universe Polymorphism. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Class Contr_internal (A : Type) := BuildContr { center : A ; contr : (forall y : A, center = y) }. +Inductive trunc_index : Type := minus_two | trunc_S (x : trunc_index). +Bind Scope trunc_scope with trunc_index. +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. +Notation minus_one:=(trunc_S minus_two). +Notation "0" := (trunc_S minus_one) : trunc_scope. +Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. +Notation IsHProp := (IsTrunc minus_one). +Notation IsHSet := (IsTrunc 0). +Goal forall (A : Type) (a b : A) (H' : IsHSet A), { x : Type & IsHProp x }. +Proof. +intros. +eexists. +(* exact (H' a b). *) +(* Undo. *) +apply (H' a b). +Qed. diff --git a/test-suite/bugs/closed/3427.v b/test-suite/bugs/closed/3427.v new file mode 100644 index 00000000..8483a4ec --- /dev/null +++ b/test-suite/bugs/closed/3427.v @@ -0,0 +1,195 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* File reduced by coq-bug-finder from original input, then from 0 lines to 7171 lines, then from 7184 lines to 558 lines, then from 556 lines to 209 lines *) +Generalizable All Variables. +Set Universe Polymorphism. +Notation Type0 := Set. +Notation idmap := (fun x => x). +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. +Open Scope function_scope. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Delimit Scope path_scope with path. +Local Open Scope path_scope. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end. +Notation "1" := idpath : path_scope. +Notation "p @ q" := (concat p q) (at level 20) : path_scope. +Notation "p ^" := (inverse p) (at level 3) : path_scope. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end. +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) := forall x:A, f x = g x. +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) : forall x, f x = g x := fun x => match h with idpath => idpath end. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) + }. +Record Equiv A B := BuildEquiv { + equiv_fun :> A -> B ; + equiv_isequiv :> IsEquiv equiv_fun + }. + +Delimit Scope equiv_scope with equiv. + +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) + }. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint nat_to_trunc_index (n : nat) : trunc_index + := match n with + | 0 => trunc_S (trunc_S minus_two) + | S n' => trunc_S (nat_to_trunc_index n') + end. + +Coercion nat_to_trunc_index : nat >-> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Notation minus_one:=(trunc_S minus_two). + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Notation Contr := (IsTrunc minus_two). +Notation IsHProp := (IsTrunc minus_one). +Notation IsHSet := (IsTrunc 0). + +Class Funext := + { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. + +Definition concat_pV {A : Type} {x y : A} (p : x = y) : + p @ p^ = 1 + := + match p with idpath => 1 end. + +Definition concat_Vp {A : Type} {x y : A} (p : x = y) : + p^ @ p = 1 + := + match p with idpath => 1 end. + +Definition transport_pp {A : Type} (P : A -> Type) {x y z : A} (p : x = y) (q : y = z) (u : P x) : + p @ q # u = q # p # u := + match q with idpath => + match p with idpath => 1 end + end. + +Definition transport2 {A : Type} (P : A -> Type) {x y : A} {p q : x = y} + (r : p = q) (z : P x) +: p # z = q # z + := ap (fun p' => p' # z) r. + +Inductive Unit : Type0 := + tt : Unit. + +Instance contr_unit : Contr Unit | 0 := let x := {| + center := tt; + contr := fun t : Unit => match t with tt => 1 end + |} in x. + +Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. +admit. +Defined. + +Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. +Definition Unit_hp:hProp:=(hp Unit _). + +Global Instance isequiv_ap_hproptype `{Funext} X Y : IsEquiv (@ap _ _ hproptype X Y). +admit. +Defined. + +Definition path_hprop `{Funext} X Y := (@ap _ _ hproptype X Y)^-1%equiv. + +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Local Open Scope equiv_scope. + +Instance isequiv_path {A B : Type} (p : A = B) +: IsEquiv (transport (fun X:Type => X) p) | 0 + := BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) + (fun b => ((transport_pp idmap p^ p b)^ @ transport2 idmap (concat_Vp p) b)) + (fun a => ((transport_pp idmap p p^ a)^ @ transport2 idmap (concat_pV p) a)) + (fun a => match p in _ = C return + (transport_pp idmap p^ p (transport idmap p a))^ @ + transport2 idmap (concat_Vp p) (transport idmap p a) = + ap (transport idmap p) ((transport_pp idmap p p^ a) ^ @ + transport2 idmap (concat_pV p) a) with idpath => 1 end). + +Definition equiv_path (A B : Type) (p : A = B) : A <~> B + := BuildEquiv _ _ (transport (fun X:Type => X) p) _. + +Class Univalence := { + isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B) + }. + +Section Univalence. + Context `{Univalence}. + + Definition path_universe_uncurried {A B : Type} (f : A <~> B) : A = B + := (equiv_path A B)^-1 f. +End Univalence. + +Local Inductive minus1Trunc (A :Type) : Type := + min1 : A -> minus1Trunc A. + +Instance minus1Trunc_is_prop {A : Type} : IsHProp (minus1Trunc A) | 0. +admit. +Defined. + +Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT P). + +Section AssumingUA. + + Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, + forall g h: Y -> Z, g o f = h o f -> g = h. + Context {X Y : hSet} (f : X -> Y) (Hisepi : isepi f). + + Goal forall (X Y : hSet) (f : forall _ : setT X, setT Y), + let fib := + fun y : setT Y => + hp (@hexists (setT X) (fun x : setT X => @paths (setT Y) (f x) y)) + (@minus1Trunc_is_prop + (@sigT (setT X) (fun x : setT X => @paths (setT Y) (f x) y))) in + forall (x : setT X) (_ : Univalence) (_ : Funext), + @paths hProp (fib (f x)) Unit_hp. + intros. + + apply path_hprop. + simpl. + Set Printing Universes. + Set Printing All. + refine (path_universe_uncurried _). + Undo. + apply path_universe_uncurried. (* Toplevel input, characters 21-44: +Error: Refiner was given an argument + "@path_universe_uncurried (* Top.425 Top.426 Top.427 Top.428 Top.429 *) X1 + (@hexists (* Top.405 Top.404 Set Set *) (setT (* Top.405 *) X0) + (fun x0 : setT (* Top.405 *) X0 => + @paths (* Top.404 *) (setT (* Top.404 *) Y0) (f0 x0) (f0 x))) Unit + ?63" of type + "@paths (* Top.428 *) Type (* Top.425 *) + (@hexists (* Top.405 Top.404 Set Set *) (setT (* Top.405 *) X0) + (fun x0 : setT (* Top.405 *) X0 => + @paths (* Top.404 *) (setT (* Top.404 *) Y0) (f0 x0) (f0 x))) Unit" +instead of + "@paths (* Top.413 *) Type (* Set *) + (@hexists (* Top.405 Top.404 Set Set *) (setT (* Top.405 *) X0) + (fun x0 : setT (* Top.405 *) X0 => + @paths (* Top.404 *) (setT (* Top.404 *) Y0) (f0 x0) (f0 x))) Unit". + *) diff --git a/test-suite/bugs/closed/3428.v b/test-suite/bugs/closed/3428.v new file mode 100644 index 00000000..3eb75e43 --- /dev/null +++ b/test-suite/bugs/closed/3428.v @@ -0,0 +1,35 @@ +(* File reduced by coq-bug-finder from original input, then from 2809 lines to 39 lines *) +Set Primitive Projections. +Set Implicit Arguments. +Module Export foo. + Record prod (A B : Type) := pair { fst : A ; snd : B }. +End foo. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end. +Axiom path_prod : forall {A B : Type} (z z' : prod A B), (fst z = fst z') -> (snd z = snd z') -> (z = z'). +Notation fst := (@fst _ _). +Notation snd := (@snd _ _). +Definition ap_fst_path_prod {A B : Type} {z z' : prod A B} (p : @paths A (fst z) (fst z')) (q : snd z = snd z') +: ap fst (path_prod z z' p q) = p. +Abort. + +Notation fstp x := (x.(foo.fst)). +Notation fstap x := (foo.fst x). + +Definition ap_fst_path_prod' {A B : Type} {z z' : prod A B} (p : @paths A (fst z) (fst z')) (q : snd z = snd z') +: ap (fun x => fstap x) (path_prod z z' p q) = p. + +Abort. + +(* Toplevel input, characters 137-138: +Error: +In environment +A : Type +B : Type +z : prod A B +z' : prod A B +p : @paths A (foo.fst ?11 ?14 z) (foo.fst ?26 ?29 z') +q : @paths ?54 (foo.snd ?42 ?45 z) (foo.snd ?57 ?60 z') +The term "p" has type "@paths A (foo.fst ?11 ?14 z) (foo.fst ?26 ?29 z')" +while it is expected to have type "@paths A (foo.fst z) (foo.fst z')". *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3439.v b/test-suite/bugs/closed/3439.v new file mode 100644 index 00000000..bba6140f --- /dev/null +++ b/test-suite/bugs/closed/3439.v @@ -0,0 +1,43 @@ +(* File reduced by coq-bug-finder from original input, then from 3154 lines to 149 lines, then from 89 lines to 55 lines, then from 44 lines to 20 lines *) +Set Primitive Projections. +Generalizable All Variables. +Axiom IsHSet : Type -> Type. +Existing Class IsHSet. +Record PreCategory := { object :> Type }. +Notation IsStrictCategory C := (IsHSet (object C)). +Instance trunc_prod `{IsHSet A} `{IsHSet B} : IsHSet (A * B) | 100. +admit. +Defined. +Typeclasses Transparent object. +Definition prod (C D : PreCategory) : PreCategory := Build_PreCategory (Datatypes.prod C D). +Global Instance isstrict_category_product `{IsStrictCategory C, IsStrictCategory D} : IsStrictCategory (prod C D). +Proof. + typeclasses eauto. +Defined. + + +Set Typeclasses Debug. +(* File reduced by coq-bug-finder from original input, then from 7425 lines to 154 lines, then from 116 lines to 20 lines *) +Class Contr (A : Type) := { center : A }. +Instance contr_unit : Contr unit | 0 := {| center := tt |}. +Module non_prim. + Unset Primitive Projections. + Record PreCategory := { object :> Type }. + Lemma foo : Contr (object (@Build_PreCategory unit)). + Proof. + solve [ simpl; typeclasses eauto ] || fail "goal not solved". + Undo. + solve [ typeclasses eauto ]. + Defined. +End non_prim. + +Module prim. + Set Primitive Projections. + Record PreCategory := { object :> Type }. + Lemma foo : Contr (object (@Build_PreCategory unit)). + Proof. + solve [ simpl; typeclasses eauto ] || fail "goal not solved". + Undo. + solve [ typeclasses eauto ]. (* Error: No applicable tactic. *) + Defined. +End prim. \ No newline at end of file diff --git a/test-suite/bugs/closed/3453.v b/test-suite/bugs/closed/3453.v new file mode 100644 index 00000000..4ee9b400 --- /dev/null +++ b/test-suite/bugs/closed/3453.v @@ -0,0 +1,10 @@ +Set Primitive Projections. +Record Foo := { bar : Set }. +Class Baz (F : Foo) := { qux : F.(bar) }. +Coercion qux : Baz >-> bar. + +Definition f : Foo := {| bar := nat |}. +Canonical Structure f. +Check (fun b : Baz f => b : _.(bar)). + +(* Error: Found target class bar instead of bar. *) diff --git a/test-suite/bugs/closed/3454.v b/test-suite/bugs/closed/3454.v new file mode 100644 index 00000000..ca4d2380 --- /dev/null +++ b/test-suite/bugs/closed/3454.v @@ -0,0 +1,63 @@ +Set Primitive Projections. +Set Implicit Arguments. + +Record prod {A} {B}:= pair { fst : A ; snd : B }. +Notation " A * B " := (@prod A B) : type_scope. +Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. +Notation pr1 := (@projT1 _ _). +Arguments prod : clear implicits. + +Check (@projT1 _ (fun x : nat => x = x)). +Check (fun s : @sigT nat (fun x : nat => x = x) => s.(projT1)). + +Record rimpl {b : bool} {n : nat} := { foo : forall {x : nat}, x = n }. + +Check (fun r : @rimpl true 0 => r.(foo) (x:=0)). +Check (fun r : @rimpl true 0 => @foo true 0 r 0). +Check (fun r : @rimpl true 0 => foo r (x:=0)). +Check (fun r : @rimpl true 0 => @foo _ _ r 0). +Check (fun r : @rimpl true 0 => r.(@foo _ _)). +Check (fun r : @rimpl true 0 => r.(foo)). + +Notation "{ x : T & P }" := (@sigT T P). +Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope. +(* Notation "{ x : T * U & P }" := (@sigT (T * U) P). *) + +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Class IsEquiv {A B : Type} (f : A -> B) := {}. + +Local Instance isequiv_tgt_compose A B +: @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) + (A -> B) + (@compose A {xy : B * B & fst xy = snd xy} B + (@compose {xy : B * B & fst xy = snd xy} _ B (@snd B B) pr1)). +(* Toplevel input, characters 220-223: *) +(* Error: Cannot infer this placeholder. *) + +Local Instance isequiv_tgt_compose' A B +: @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) + (A -> B) + (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) pr1)). +(* Toplevel input, characters 221-232: *) +(* Error: *) +(* In environment *) +(* A : Type *) +(* B : Type *) +(* The term "pr1" has type "sigT ?30 -> ?29" while it is expected to have type *) +(* "{xy : B * B & fst xy = snd xy} -> ?27 * B". *) + +Local Instance isequiv_tgt_compose'' A B +: @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) + (A -> B) + (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) + (fun s => s.(projT1)))). +(* Toplevel input, characters 15-241: +Error: +Cannot infer an internal placeholder of type "Type" in environment: + +A : Type +B : Type +x : ?32 +. *) diff --git a/test-suite/bugs/closed/3469.v b/test-suite/bugs/closed/3469.v new file mode 100644 index 00000000..b09edc65 --- /dev/null +++ b/test-suite/bugs/closed/3469.v @@ -0,0 +1,29 @@ +(* File reduced by coq-bug-finder from original input, then from 538 lines to 31 lines *) +Open Scope type_scope. +Global Set Primitive Projections. +Set Implicit Arguments. +Record sig (A : Type) (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P proj1_sig }. +Notation sigT := sig (only parsing). +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. +Notation projT1 := proj1_sig (only parsing). +Notation projT2 := proj2_sig (only parsing). +Variables X : Type. +Variable R : X -> X -> Type. +Lemma dependent_choice : + (forall x:X, {y : _ & R x y}) -> + forall x0, {f : nat -> X & (f O = x0) * (forall n, R (f n) (f (S n)))}. +Proof. + intros H x0. + set (f:=fix f n := match n with O => x0 | S n' => projT1 (H (f n')) end). + exists f. + split. + reflexivity. + induction n; simpl in *. + clear. + apply (proj2_sig (H x0)). + Undo. + apply @proj2_sig. + + +(* Toplevel input, characters 21-31: +Error: Found no subterm matching "proj1_sig ?206" in the current *) diff --git a/test-suite/bugs/closed/3477.v b/test-suite/bugs/closed/3477.v new file mode 100644 index 00000000..e9414864 --- /dev/null +++ b/test-suite/bugs/closed/3477.v @@ -0,0 +1,9 @@ +Set Primitive Projections. +Set Implicit Arguments. +Record prod A B := pair { fst : A ; snd : B }. +Goal forall A B : Set, True. +Proof. + intros A B. + evar (a : prod A B); evar (f : (prod A B -> Set)). + let a' := (eval unfold a in a) in + set(foo:=eq_refl : a' = (@pair _ _ (fst a') (snd a'))). \ No newline at end of file diff --git a/test-suite/bugs/closed/348.v b/test-suite/bugs/closed/348.v new file mode 100644 index 00000000..28cc5cb1 --- /dev/null +++ b/test-suite/bugs/closed/348.v @@ -0,0 +1,13 @@ +Module Type S. + Parameter empty: Set. +End S. + +Module D (M:S). + Import M. + Definition empty:=nat. +End D. + +Module D' (M:S). + Import M. + Definition empty:Set. exact nat. Save. +End D'. diff --git a/test-suite/bugs/closed/3480.v b/test-suite/bugs/closed/3480.v new file mode 100644 index 00000000..99ac2efa --- /dev/null +++ b/test-suite/bugs/closed/3480.v @@ -0,0 +1,47 @@ +Set Primitive Projections. +Axiom admit : forall {T}, T. +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. +Notation "x .1" := (projT1 x) (at level 3) : fibration_scope. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Set Implicit Arguments. +Delimit Scope category_scope with category. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Local Open Scope category_scope. +Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }. +Class Isomorphic {C : PreCategory} s d := { morphism_isomorphic :> @morphism C s d ; isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic }. +Coercion morphism_isomorphic : Isomorphic >-> morphism. +Local Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope. +Definition idtoiso (C : PreCategory) (x y : C) (H : x = y) : Isomorphic x y := admit. +Record NotionOfStructure (X : PreCategory) := { structure :> X -> Type }. +Record Smorphism (X : PreCategory) (P : NotionOfStructure X) (xa yb : { x : X & P x }) := { f : morphism X xa.1 yb.1 }. +Definition precategory_of_structures X (P : NotionOfStructure X) : PreCategory. +Proof. + refine (@Build_PreCategory _ (@Smorphism _ P)). +Defined. +Section sip. + Variable X : PreCategory. + Variable P : NotionOfStructure X. + + Let StrX := @precategory_of_structures X P. + + Definition sip_isotoid (xa yb : StrX) (f : xa <~=~> yb) : xa = yb. + admit. + Defined. + + Lemma structure_identity_principle_helper (xa yb : StrX) + (x : xa <~=~> yb) : Smorphism P xa yb. + Proof. + refine ((idtoiso (precategory_of_structures P) (sip_isotoid x) : @morphism _ _ _) : morphism _ _ _). +(* Toplevel input, characters 24-95: +Error: +In environment +X : PreCategory +P : NotionOfStructure X +StrX := precategory_of_structures P : PreCategory +xa : object StrX +yb : object StrX +x : xa <~=~> yb +The term "morphism_isomorphic:@morphism (precategory_of_structures P) xa yb" +has type "@morphism (precategory_of_structures P) xa yb" +while it is expected to have type "morphism ?40 ?41 ?42". *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3481.v b/test-suite/bugs/closed/3481.v new file mode 100644 index 00000000..89d476dc --- /dev/null +++ b/test-suite/bugs/closed/3481.v @@ -0,0 +1,70 @@ + +Set Implicit Arguments. + +Require Import Logic. +Module NonPrim. +Local Set Record Elimination Schemes. +Record prodwithlet (A B : Type) : Type := + pair' { fst : A; fst' := fst; snd : B }. + +Definition letreclet (p : prodwithlet nat nat) := + let (x, x', y) := p in x + y. + +Definition pletreclet (p : prodwithlet nat nat) := + let 'pair' x x' y := p in x + y + x'. + +Definition pletreclet2 (p : prodwithlet nat nat) := + let 'pair' x y := p in x + y. + +Check (pair 0 0). +End NonPrim. + +Global Set Universe Polymorphism. +Global Set Asymmetric Patterns. +Local Set Record Elimination Schemes. +Local Set Primitive Projections. + +Record prod (A B : Type) : Type := + pair { fst : A; snd : B }. + +Print prod_rect. + +(* What I really want: *) +Definition prod_rect' A B (P : prod A B -> Type) (u : forall (fst : A) (snd : B), P (pair fst snd)) + (p : prod A B) : P p + := u (fst p) (snd p). + +Definition conv : @prod_rect = @prod_rect'. +Proof. reflexivity. Defined. + +Definition imposs := + (fun A B P f (p : prod A B) => match p as p0 return P p0 with + | {| fst := x ; snd := x0 |} => f x x0 + end). + +Definition letrec (p : prod nat nat) := + let (x, y) := p in x + y. +Eval compute in letrec (pair 1 5). + +Goal forall p : prod nat nat, letrec p = fst p + snd p. +Proof. + reflexivity. + Undo. + intros p. + case p. simpl. unfold letrec. simpl. reflexivity. +Defined. + +Eval compute in conv. (* = eq_refl + : prod_rect = prod_rect' *) + +Check eq_refl : @prod_rect = @prod_rect'. (* Toplevel input, characters 6-13: +Error: +The term "eq_refl" has type "prod_rect = prod_rect" +while it is expected to have type "prod_rect = prod_rect'" +(cannot unify "prod_rect" and "prod_rect'"). *) + +Record sigma (A : Type) (B : A -> Type) : Type := + dpair { pi1 : A ; pi2 : B pi1 }. + + + diff --git a/test-suite/bugs/closed/3482.v b/test-suite/bugs/closed/3482.v new file mode 100644 index 00000000..34a5e73d --- /dev/null +++ b/test-suite/bugs/closed/3482.v @@ -0,0 +1,11 @@ +Set Primitive Projections. +Class Foo (F : False) := { foo : True }. +Arguments foo F {Foo}. +Print Implicit foo. (* foo : forall F : False, Foo F -> True + +Argument Foo is implicit and maximally inserted *) +Check foo _. (* Toplevel input, characters 6-11: +Error: Illegal application (Non-functional construction): +The expression "foo" of type "True" +cannot be applied to the term + "?36" : "?35" *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3483.v b/test-suite/bugs/closed/3483.v new file mode 100644 index 00000000..2cc66186 --- /dev/null +++ b/test-suite/bugs/closed/3483.v @@ -0,0 +1,5 @@ +(* Check proper failing when using notation of non-constructors in + pattern-bmatching *) + +Fail Definition nonsense ( x : False ) := match x with y + 2 => 0 end. + diff --git a/test-suite/bugs/closed/3484.v b/test-suite/bugs/closed/3484.v new file mode 100644 index 00000000..6c40a426 --- /dev/null +++ b/test-suite/bugs/closed/3484.v @@ -0,0 +1,30 @@ +(* File reduced by coq-bug-finder from original input, then from 14259 lines to 305 lines, then from 237 lines to 120 lines, then from 100 lines to 30 lines *) +Set Primitive Projections. +Set Implicit Arguments. +Record sigT (A : Type) (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. +Notation "{ x : A & P }" := (@sigT A (fun x : A => P)) : type_scope. +Notation pr1 := (@projT1 _ _). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end. +Goal forall (T : Type) (H : { g : T & g = g }) (x : T), projT1 H = projT1 (existT (fun g : T => g = g) x idpath). +Proof. + intros. + let y := match goal with |- projT1 ?x = projT1 ?y => constr:(y) end in + apply (@ap _ _ pr1 _ y). + Undo. + Unset Printing Notations. + apply (ap pr1). + Undo. + refine (ap pr1 _). +admit. +Defined. + +(* Toplevel input, characters 22-28: +Error: +In environment +T : Type +H : sigT T (fun g : T => paths g g) +x : T +Unable to unify "paths (@projT1 ?24 ?23 ?25) (@projT1 ?24 ?23 ?26)" with + "paths (projT1 H) (projT1 {| projT1 := x; projT2 := idpath |})". *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3485.v b/test-suite/bugs/closed/3485.v new file mode 100644 index 00000000..ede6b3cb --- /dev/null +++ b/test-suite/bugs/closed/3485.v @@ -0,0 +1,133 @@ +Set Universe Polymorphism. +Set Primitive Projections. +Reserved Infix "o" (at level 40, left associativity). +Definition relation (A : Type) := A -> A -> Type. +Class Transitive {A} (R : relation A) := transitivity : forall x y z, R x y -> R y z -> R x z. +Tactic Notation "etransitivity" open_constr(y) := + let R := match goal with |- ?R ?x ?z => constr:(R) end in + let x := match goal with |- ?R ?x ?z => constr:(x) end in + let z := match goal with |- ?R ?x ?z => constr:(z) end in + refine (@transitivity _ R _ x y z _ _). +Tactic Notation "etransitivity" := etransitivity _. +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. +Notation "x .1" := (projT1 x) (at level 3) : fibration_scope. +Notation "x .2" := (projT2 x) (at level 3) : fibration_scope. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end. +Instance transitive_paths {A} : Transitive (@paths A) | 0 := @concat A. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. +Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center = y) }. +Generalizable Variables X A B C f g n. +Definition projT1_path `{P : A -> Type} {u v : sigT P} (p : u = v) : u.1 = v.1 := ap (@projT1 _ _) p. +Notation "p ..1" := (projT1_path p) (at level 3) : fibration_scope. +Ltac simpl_do_clear tac term := + let H := fresh in + assert (H := term); + simpl in H |- *; + tac H; + clear H. +Set Implicit Arguments. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f }. +Arguments identity {C%category} / x%object : rename. +Arguments compose {C%category} / {s d d'}%object (m1 m2)%morphism : rename. +Infix "o" := compose : morphism_scope. +Notation "1" := (identity _) : morphism_scope. +Delimit Scope functor_scope with functor. +Local Open Scope morphism_scope. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) }. +Bind Scope functor_scope with Functor. +Arguments morphism_of [C%category] [D%category] F%functor / [s%object d%object] m%morphism : rename. +Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. +Section composition. + Variable C : PreCategory. + Variable D : PreCategory. + Variable E : PreCategory. + Variable G : Functor D E. + Variable F : Functor C D. + + Local Notation c_object_of c := (G (F c)) (only parsing). + Local Notation c_morphism_of m := (morphism_of G (morphism_of F m)) (only parsing). + + Definition compose_identity_of x + : c_morphism_of (identity x) = identity (c_object_of x) + := transport (@paths _ _) + (identity_of G _) + (ap (@morphism_of _ _ G _ _) (identity_of F x)). + + Definition composeF : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => morphism_of G (morphism_of F m)) + compose_identity_of. +End composition. +Infix "o" := composeF : functor_scope. + +Definition identityF C : Functor C C + := Build_Functor C C + (fun x => x) + (fun _ _ x => x) + (fun _ => idpath). +Notation "1" := (identityF _) : functor_scope. + +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. + +Section unit. + Variable C : PreCategory. + Variable D : PreCategory. + Variable F : Functor C D. + Variable G : Functor D C. + + Definition AdjunctionUnit := + { T : NaturalTransformation 1 (G o F) + & forall (c : C) (d : D) (f : morphism C c (G d)), + Contr_internal { g : morphism D (F c) d & G _1 g o T c = f } + }. +End unit. +Variable C : PreCategory. +Variable D : PreCategory. +Variable F : Functor C D. +Variable G : Functor D C. + +Definition zig__of__adjunction_unit + (A : AdjunctionUnit F G) + (Y : C) + (eta := A.1) + (eps := fun X => (@center _ (A.2 (G X) X 1)).1) +: G _1 (eps (F Y) o F _1 (eta Y)) o eta Y = eta Y + -> eps (F Y) o F _1 (eta Y) = 1. +Proof. + intros. + etransitivity; [ symmetry | ]; + simpl_do_clear + ltac:(fun H => apply H) + (fun y H => (@contr _ (A.2 _ _ (A.1 Y)) (y; H))..1); + try assumption. + simpl. + rewrite ?@identity_of, ?@left_identity, ?@right_identity; + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/3487.v b/test-suite/bugs/closed/3487.v new file mode 100644 index 00000000..03c60a8b --- /dev/null +++ b/test-suite/bugs/closed/3487.v @@ -0,0 +1,8 @@ +Notation bar := $(exact I)$. +Notation foo := bar (only parsing). +Class baz := { x : False }. +Instance: baz. +Admitted. +Definition baz0 := ((_ : baz) = (_ : baz)). +Definition foo1 := (foo = foo). +Definition baz1 := prod ((_ : baz) = (_ : baz)) (foo = foo). diff --git a/test-suite/bugs/closed/3505.v b/test-suite/bugs/closed/3505.v new file mode 100644 index 00000000..2695bc79 --- /dev/null +++ b/test-suite/bugs/closed/3505.v @@ -0,0 +1,44 @@ +(* File reduced by coq-bug-finder from original input, then from 7421 lines to 6082 lines, then from 5860 lines to 5369 lines, then from 5300 lines to 165 lines, then from 111 lines to 38 lines *) +Set Implicit Arguments. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + identity : forall x, morphism x x }. +Bind Scope category_scope with PreCategory. +Local Notation "1" := (identity _ _) : morphism_scope. +Local Open Scope morphism_scope. +Definition prod (C D : PreCategory) : PreCategory + := @Build_PreCategory + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type) + (fun x => (identity _ (fst x), identity _ (snd x))). +Local Infix "*" := prod : category_scope. +Module NonPrim. + Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); + identity_of : forall x, morphism_of _ _ (identity _ x) = identity _ (object_of x) }. + Notation "F '_1' m" := (morphism_of F _ _ m) (at level 10, no associativity) : morphism_scope. + Goal forall C1 C2 D (F : Functor (C1 * C2) D) x, F _1 (1, 1) = identity _ (F x). + Proof. + intros. + rewrite identity_of. + reflexivity. + Qed. +End NonPrim. +Module Prim. + Set Primitive Projections. + Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); + identity_of : forall x, morphism_of _ _ (identity _ x) = identity _ (object_of x) }. + Notation "F '_1' m" := (morphism_of F _ _ m) (at level 10, no associativity) : morphism_scope. + Goal forall C1 C2 D (F : Functor (C1 * C2) D) x, F _1 (1, 1) = identity _ (F x). + Proof. + intros. + rewrite identity_of. (* Toplevel input, characters 0-20: +Error: +Found no subterm matching "morphism_of ?192 ?193 ?193 (identity ?190 ?193)" in the current goal. *) + reflexivity. + Qed. +End Prim. diff --git a/test-suite/bugs/closed/3520.v b/test-suite/bugs/closed/3520.v new file mode 100644 index 00000000..c981207e --- /dev/null +++ b/test-suite/bugs/closed/3520.v @@ -0,0 +1,12 @@ +Set Primitive Projections. + +Record foo (A : Type) := + { bar : Type ; baz := Set; bad : baz = bar }. + +Set Record Elimination Schemes. + +Record notprim : Prop := + { irrel : True; relevant : nat }. + + + diff --git a/test-suite/bugs/closed/3531.v b/test-suite/bugs/closed/3531.v new file mode 100644 index 00000000..fd080a6b --- /dev/null +++ b/test-suite/bugs/closed/3531.v @@ -0,0 +1,53 @@ +(* File reduced by coq-bug-finder from original input, then from 270 lines to +198 lines, then from 178 lines to 82 lines, then from 88 lines to 59 lines *) +(* coqc version trunk (August 2014) compiled on Aug 19 2014 14:40:15 with OCaml +4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk +(56ece74efc25af1b0e09265f3c7fcf74323abcaf) *) +Require Import Coq.Lists.List. +Set Implicit Arguments. +Definition mem := nat -> option nat. +Definition pred := mem -> Prop. +Delimit Scope pred_scope with pred. +Definition exis A (p : A -> pred) : pred := fun m => exists x, p x m. +Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : +pred_scope. +Definition emp : pred := fun m => forall a, m a = None. +Definition lift_empty (P : Prop) : pred := fun m => P /\ forall a, m a = None. +Notation "[[ P ]]" := (lift_empty P) : pred_scope. +Definition pimpl (p q : pred) := forall m, p m -> q m. +Notation "p ==> q" := (pimpl p%pred q%pred) (right associativity, at level 90). +Definition piff (p q : pred) : Prop := (p ==> q) /\ (q ==> p). +Notation "p <==> q" := (piff p%pred q%pred) (at level 90). +Parameter sep_star : pred -> pred -> pred. +Infix "*" := sep_star : pred_scope. +Definition memis (m : mem) : pred := eq m. +Definition mptsto (m : mem) (a : nat) (v : nat) := m a = Some v. +Notation "m @ a |-> v" := (mptsto m a v) (a at level 34, at level 35). +Lemma piff_trans: forall a b c, (a <==> b) -> (b <==> c) -> (a <==> c). +Admitted. +Lemma piff_refl: forall a, (a <==> a). +Admitted. +Definition stars (ps : list pred) := fold_left sep_star ps emp. +Lemma flatten_exists: forall T PT p ps P, + (forall (a:T), (p a <==> exists (x:PT), stars (ps a x) * [[P a x]])) + -> (exists (a:T), p a) <==> + (exists (x:(T*PT)), stars (ps (fst x) (snd x)) * [[P (fst x) (snd x)]]). +Admitted. +Goal forall b, (exists e1 e2 e3, + (exists (m : mem) (v : nat) (F : pred), b) + <==> (exists x : e1, stars (e2 x) * [[e3 x]])). + intros. + Set Printing Universes. + Show Universes. + do 3 eapply ex_intro. + eapply piff_trans; [ apply flatten_exists | apply piff_refl ]; intros. + eapply piff_trans; [ apply flatten_exists | apply piff_refl ]; intros. + eapply piff_trans; [ apply flatten_exists | apply piff_refl ]; intros. + assert (H : False) by (clear; admit); destruct H. + Grab Existential Variables. + admit. + admit. + admit. + Show Universes. +Time Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/3537.v b/test-suite/bugs/closed/3537.v new file mode 100644 index 00000000..158642f0 --- /dev/null +++ b/test-suite/bugs/closed/3537.v @@ -0,0 +1,12 @@ +(* Another instance of bug #3262, on looping in unification *) + +Inductive bool := true | false. + +Inductive RBT2 : forall a:bool, Type := + Full2 : forall (a b c n:bool), + forall H:RBT2 n, RBT2 n. + +Definition balance4 color p q r := + match color, p, q, r with + | _,_,_,_ => Full2 color p q r + end. diff --git a/test-suite/bugs/closed/3539.v b/test-suite/bugs/closed/3539.v new file mode 100644 index 00000000..c862965d --- /dev/null +++ b/test-suite/bugs/closed/3539.v @@ -0,0 +1,66 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter" "-no-native-compiler") -*- *) +(* File reduced by coq-bug-finder from original input, then from 11678 lines to 11330 lines, then from 10721 lines to 9544 lines, then from 9549 lines to 794 lines, then from 810 lines to 785 lines, then from 628 lines to 246 lines, then from 220 lines to 89 lines, then from 80 lines to 47 lines *) +(* coqc version trunk (August 2014) compiled on Aug 22 2014 4:17:28 with OCaml 4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (a67cc6941434124465f20b14a1256f2ede31a60e) *) + +Set Implicit Arguments. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Local Set Primitive Projections. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Axiom path_prod : forall {A B : Type} (z z' : A * B), (fst z = fst z') -> (snd z = snd z') -> (z = z'). +Axiom transport_path_prod : forall A B (P : A * B -> Type) (x y : A * B) (HA : fst x = fst y) (HB : snd x = snd y) Px, + transport P (path_prod _ _ HA HB) Px + = transport (fun x => P (x, snd y)) HA (transport (fun y => P (fst x, y)) HB Px). +Goal forall (T0 : Type) (snd1 snd0 f : T0) (p : @paths T0 f snd0) + (f0 : T0) (p1 : @paths T0 f0 snd1) (T1 : Type) + (fst1 fst0 : T1) (p0 : @paths T1 fst0 fst0) (p2 : @paths T1 fst1 fst1) + (T : Type) (x2 : T) (T2 : Type) (T3 : forall (_ : T2) (_ : T2), Type) + (x' : forall (_ : T1) (_ : T), T2) (m : T3 (x' fst1 x2) (x' fst0 x2)), + @paths (T3 (x' fst1 x2) (x' fst0 x2)) + (@transport (prod T1 T0) + (fun x : prod T1 T0 => + T3 (x' fst1 x2) (x' (fst x) x2)) + (@pair T1 T0 fst0 f) (@pair T1 T0 fst0 snd0) + (@path_prod T1 T0 (@pair T1 T0 fst0 f) + (@pair T1 T0 fst0 snd0) p0 p) + (@transport (prod T1 T0) + (fun x : prod T1 T0 => + T3 (x' (fst x) x2) (x' fst0 x2)) + (@pair T1 T0 fst1 f0) (@pair T1 T0 fst1 snd1) + (@path_prod T1 T0 (@pair T1 T0 fst1 f0) + (@pair T1 T0 fst1 snd1) p2 p1) m)) m. + intros. + match goal with + | [ |- context[transport ?P (path_prod ?x ?y ?HA ?HB) ?Px] ] + => rewrite (transport_path_prod P x y HA HB Px) + end || fail "bad". + Undo. + Set Printing All. + rewrite transport_path_prod. (* Toplevel input, characters 15-43: +Error: +In environment +T0 : Type +snd1 : T0 +snd0 : T0 +f : T0 +p : @paths T0 f snd0 +f0 : T0 +p1 : @paths T0 f0 snd1 +T1 : Type +fst1 : T1 +fst0 : T1 +p0 : @paths T1 fst0 fst0 +p2 : @paths T1 fst1 fst1 +T : Type +x2 : T +T2 : Type +T3 : forall (_ : T2) (_ : T2), Type +x' : forall (_ : T1) (_ : T), T2 +m : T3 (x' fst1 x2) (x' fst0 x2) +Unable to unify "?25 (@pair ?23 ?24 (fst ?27) (snd ?27))" with +"?25 ?27". + *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3542.v b/test-suite/bugs/closed/3542.v new file mode 100644 index 00000000..b6837a0c --- /dev/null +++ b/test-suite/bugs/closed/3542.v @@ -0,0 +1,6 @@ +Section foo. + Context {A:Type} {B : A -> Type}. + Context (f : forall x, B x). + Goal True. + pose (r := fun k => existT (fun g => forall x, f x = g x) + (fun x => projT1 (k x)) (fun x => projT2 (k x))). diff --git a/test-suite/bugs/closed/3546.v b/test-suite/bugs/closed/3546.v new file mode 100644 index 00000000..55d718bd --- /dev/null +++ b/test-suite/bugs/closed/3546.v @@ -0,0 +1,17 @@ +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. +Arguments pair {_ _} _ _. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Definition ap11 {A B} {f g:A->B} (h:f=g) {x y:A} (p:x=y) : f x = g y. +Admitted. +Goal forall x y z w : Set, (x, y) = (z, w). +Proof. + intros. + apply ap11. (* Toplevel input, characters 21-25: +Error: In environment +x : Set +y : Set +z : Set +w : Set +Unable to unify "?31 ?191 = ?32 ?192" with "(x, y) = (z, w)". + *) diff --git a/test-suite/bugs/closed/3559.v b/test-suite/bugs/closed/3559.v new file mode 100644 index 00000000..50645090 --- /dev/null +++ b/test-suite/bugs/closed/3559.v @@ -0,0 +1,86 @@ +(* File reduced by coq-bug-finder from original input, then from 8657 lines to +4731 lines, then from 4174 lines to 192 lines, then from 161 lines to 55 lines, +then from 51 lines to 37 lines, then from 43 lines to 30 lines *) +(* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml +4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk +(437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *) +Require Import Coq.Init.Notations. +Set Universe Polymorphism. +Generalizable All Variables. +Record prod A B := pair { fst : A ; snd : B }. +Arguments pair {_ _} _ _. +Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). +Reserved Notation "x <-> y" (at level 95, no associativity). +Reserved Notation "x = y" (at level 70, no associativity). +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Open Scope type_scope. + +Definition iff A B := prod (A -> B) (B -> A). +Infix "<->" := iff : type_scope. +Inductive paths {A : Type@{i}} (a : A) : A -> Type@{i} := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center += y) }. +Inductive trunc_index : Type := minus_two | trunc_S (_ : trunc_index). +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type@{i}) : Type@{i} := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. +Notation minus_one:=(trunc_S minus_two). +Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : +IsTrunc_internal n A. +Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A) : +IsTrunc n (x = y) := H x y. + +Axiom cheat : forall {A}, A. + +Lemma paths_lift (A : Type@{i}) (x y : A) (p : x = y) : paths@{j} x y. +Proof. + destruct p. apply idpath. +Defined. + +Lemma paths_change (A : Type@{i}) (x y : A) : paths@{j} x y = paths@{i} x y. +Proof. (* require Univalence *) + apply cheat. +Defined. + +Lemma IsTrunc_lift (n : trunc_index) : + forall (A : Type@{i}), IsTrunc_internal@{i} n A -> IsTrunc_internal@{j} n A. +Proof. + induction n; simpl; intros. + destruct X. exists center0. intros. apply (paths_lift _ _ _ (contr0 y)). + + rewrite paths_change. + apply IHn, X. +Defined. + +Notation IsHProp := (IsTrunc minus_one). +(* Record hProp := hp { hproptype :> Type ; isp : IsTrunc minus_one hproptype}. *) +(* Make the truncation proof polymorphic, i.e., available at any level greater or equal + to the carrier type level j *) +Record hProp := hp { hproptype :> Type@{j} ; isp : IsTrunc minus_one hproptype}. +Axiom path_iff_hprop_uncurried : forall `{IsHProp A, IsHProp B}, (A <-> B) -> A += B. +Inductive V : Type@{U'} := | set {A : Type@{U}} (f : A -> V) : V. +Axiom is0trunc_V : IsTrunc (trunc_S (trunc_S minus_two)) V. +Axiom bisimulation : V@{U' U} -> V@{U' U} -> hProp@{U'}. +Axiom bisimulation_refl : forall (v : V), bisimulation v v. +Axiom bisimulation_eq : forall (u v : V), bisimulation u v -> u = v. +Notation "u ~~ v" := (bisimulation u v) (at level 30). +Lemma bisimulation_equals_id : forall u v : V@{i j}, (u = v) = (u ~~ v). +Proof. + intros u v. + refine (@path_iff_hprop_uncurried _ _ _ _ _). +(* path_iff_hprop_uncurried : *) +(* forall A : Type@{Top.74}, *) +(* IsHProp A -> forall B : Type@{Top.74}, IsHProp B -> A <-> B -> A = B *) +(* (* Top.74 *) +(* Top.78 |= Top.74 < Top.78 *) +(* *) *) + + Show Universes. + exact (isp _). + split; intros. destruct X. apply bisimulation_refl. + apply bisimulation_eq, X. +Defined. diff --git a/test-suite/bugs/closed/3561.v b/test-suite/bugs/closed/3561.v new file mode 100644 index 00000000..b4dfd17f --- /dev/null +++ b/test-suite/bugs/closed/3561.v @@ -0,0 +1,23 @@ +(* File reduced by coq-bug-finder from original input, then from 6343 lines to 2362 lines, then from 2115 lines to 303 lines, then from 321 lines to 90 lines, then from 95 lines to 41 lines *) +(* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml 4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *) +Set Primitive Projections. +Set Implicit Arguments. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). +Lemma ap_transport {A} {P Q : A -> Type} {x y : A} (p : x = y) (f : forall x, P x -> Q x) (z : P x) : + f y (p # z) = (p # (f x z)). +Proof. admit. +Defined. +Lemma foo A B (f : A * B -> A) : f = f. +Admitted. +Goal forall (H0 H2 : Type) x p, + @transport (prod H0 H2) + (fun GO : prod H0 H2 => x (fst GO)) = p. + intros. + match goal with + | [ |- context[x (?f _)] ] => set(foo':=f) + end. \ No newline at end of file diff --git a/test-suite/bugs/closed/3562.v b/test-suite/bugs/closed/3562.v new file mode 100644 index 00000000..1a1410a3 --- /dev/null +++ b/test-suite/bugs/closed/3562.v @@ -0,0 +1,6 @@ +(* Should not be an anomaly as it was at some time in + September/October 2014 but some "Disjunctive/conjunctive + introduction pattern expected" error *) + +Theorem t: True. +Fail destruct 0 as x. diff --git a/test-suite/bugs/closed/3563.v b/test-suite/bugs/closed/3563.v new file mode 100644 index 00000000..67972166 --- /dev/null +++ b/test-suite/bugs/closed/3563.v @@ -0,0 +1,38 @@ +(* File reduced by coq-bug-finder from original input, then from 11716 lines to 11295 lines, then from 10518 lines to 21 lines, then \ +from 37 lines to 21 lines *) +(* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml 4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *) +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. +Arguments pair {A B} _ _. +Arguments fst {A B} _ / . +Arguments snd {A B} _ / . +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Goal forall (H H0 H1 : Type) (H2 : H1) (H3 : H1 -> H * H0) + (H4 : (fun c : H1 => (fst (H3 c), snd (H3 c))%core) = + H3) (H5 : H -> Type) (H6 H7 : H5 (fst (H3 H2))), + transport (fun y : H1 -> H * H0 => H5 (fst (y H2))) H4 H6 = H7. + intros. + match goal with + | [ |- appcontext ctx [transport (fun y => (?g (@fst ?C ?h (y H2)))) H4 H6] ] + => set(foo:=h); idtac + end. + match goal with + | [ |- appcontext ctx [transport (fun y => (?g (fst (y H2))))] ] + => idtac + end. +Abort. +Goal forall (H H0 H1 : Type) (H2 : H1) (H3 : H1 -> (H1 -> H) * H0) + (H4 : (fun c : H1 => (fst (H3 c), snd (H3 c))%core) = + H3) (H5 : H -> Type) (H6 H7 : H5 (fst (H3 H2) H2)), + transport (fun y : H1 -> (H1 -> H) * H0 => H5 (fst (y H2) H2)) H4 H6 = H7. + intros. + match goal with + | [ |- appcontext ctx [transport (fun y => (?g (@fst ?C ?D (y H2) ?X)))] ] + => set(foo:=X) + end. +(* Anomaly: Uncaught exception Not_found(_). Please report. *) + +(* Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/closed/3566.v b/test-suite/bugs/closed/3566.v new file mode 100644 index 00000000..b2aa8c3c --- /dev/null +++ b/test-suite/bugs/closed/3566.v @@ -0,0 +1,22 @@ +Notation idmap := (fun x => x). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Delimit Scope path_scope with path. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end. +Notation "p @ q" := (concat p q) (at level 20) : path_scope. +Notation "p ^" := (inverse p) (at level 3, format "p '^'") : path_scope. +Class IsEquiv {A B : Type} (f : A -> B) := {}. +Axiom path_universe : forall {A B : Type} (f : A -> B) {feq : IsEquiv f}, (A = B). + +Definition Lift : Type@{i} -> Type@{j} + := Eval hnf in let lt := Type@{i} : Type@{j} in fun T => T. + +Definition lift {T} : T -> Lift T := fun x => x. + +Goal forall x y : Type, x = y. + intros. + pose proof ((fun H0 : idmap _ => (@path_universe _ _ (@lift x) (H0 x) @ + (@path_universe _ _ (@lift x) (H0 x))^)))%path as H''. diff --git a/test-suite/bugs/closed/3567.v b/test-suite/bugs/closed/3567.v new file mode 100644 index 00000000..cb16b3ae --- /dev/null +++ b/test-suite/bugs/closed/3567.v @@ -0,0 +1,68 @@ + +(* File reduced by coq-bug-finder from original input, then from 2901 lines to 69 lines, then from 80 lines to 63 lines *) +(* coqc version trunk (September 2014) compiled on Sep 2 2014 2:7:1 with OCaml 4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (3c5daf4e23ee20f0788c0deab688af452e83ccf0) *) + +Set Primitive Projections. +Set Implicit Arguments. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Arguments fst {A B} _ / . +Arguments snd {A B} _ / . +Add Printing Let prod. +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Unset Implicit Arguments. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := + { equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) }. +Definition path_prod_uncurried {A B : Type} (z z' : A * B) (pq : (fst z = fst z') * (snd z = snd z')) +: (z = z') + := match fst pq in (_ = z'1), snd pq in (_ = z'2) return z = (z'1, z'2) with + | idpath, idpath => idpath + end. +Definition path_prod {A B : Type} (z z' : A * B) : + (fst z = fst z') -> (snd z = snd z') -> (z = z') + := fun p q => path_prod_uncurried z z' (p,q). +Definition path_prod' {A B : Type} {x x' : A} {y y' : B} +: (x = x') -> (y = y') -> ((x,y) = (x',y')) + := fun p q => path_prod (x,y) (x',y') p q. +Axiom ap_fst_path_prod : forall {A B : Type} {z z' : A * B} + (p : fst z = fst z') (q : snd z = snd z'), + ap fst (path_prod _ _ p q) = p. +Axiom ap_snd_path_prod : forall {A B : Type} {z z' : A * B} + (p : fst z = fst z') (q : snd z = snd z'), + ap snd (path_prod _ _ p q) = q. +Axiom eta_path_prod : forall {A B : Type} {z z' : A * B} (p : z = z'), + path_prod _ _(ap fst p) (ap snd p) = p. +Definition isequiv_path_prod {A B : Type} {z z' : A * B} : IsEquiv (path_prod_uncurried z z'). +Proof. + refine (Build_IsEquiv + _ _ _ + (fun r => (ap fst r, ap snd r)) + eta_path_prod + (fun pq => match pq with + | (p,q) => path_prod' + (ap_fst_path_prod p q) (ap_snd_path_prod p q) + end) _). + destruct z as [x y], z' as [x' y']. simpl. +(* Toplevel input, characters 15-50: +Error: Abstracting over the term "z" leads to a term +fun z0 : A * B => +forall x : (fst z0 = fst z') * (snd z0 = snd z'), +eta_path_prod (path_prod_uncurried z0 z' x) = +ap (path_prod_uncurried z0 z') + (let (p, q) as pq + return + ((ap (fst) (path_prod_uncurried z0 z' pq), + ap (snd) (path_prod_uncurried z0 z' pq)) = pq) := x in + path_prod' (ap_fst_path_prod p q) (ap_snd_path_prod p q)) +which is ill-typed. +Reason is: Pattern-matching expression on an object of inductive type prod +has invalid information. + *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3584.v b/test-suite/bugs/closed/3584.v new file mode 100644 index 00000000..3d4660b4 --- /dev/null +++ b/test-suite/bugs/closed/3584.v @@ -0,0 +1,16 @@ +Set Primitive Projections. +Set Implicit Arguments. +Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. +Definition eta_sigma {A} {P : A -> Type} (u : sigT P) + : existT _ (projT1 u) (projT2 u) = u + := match u with existT _ x y => eq_refl end. (* Toplevel input, characters 0-139: +Error: Pattern-matching expression on an object of inductive type sigT +has invalid information. *) +Definition sum_of_sigT A B (x : sigT (fun b : bool => if b then A else B)) +: A + B + := match x with + | existT _ true a => inl a + | existT _ false b => inr b + end. (* Toplevel input, characters 0-182: +Error: Pattern-matching expression on an object of inductive type sigT +has invalid information. *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3593.v b/test-suite/bugs/closed/3593.v new file mode 100644 index 00000000..25f9db6b --- /dev/null +++ b/test-suite/bugs/closed/3593.v @@ -0,0 +1,10 @@ +Set Universe Polymorphism. +Set Printing All. +Set Implicit Arguments. +Record prod A B := pair { fst : A ; snd : B }. +Goal forall x : prod Set Set, let f := @fst _ in f _ x = @fst _ _ x. +simpl; intros. + constr_eq (@fst Set Set x) (fst (A := Set) (B := Set) x). + Fail progress change (@fst Set Set x) with (fst (A := Set) (B := Set) x). + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/3594.v b/test-suite/bugs/closed/3594.v new file mode 100644 index 00000000..d1aae7b4 --- /dev/null +++ b/test-suite/bugs/closed/3594.v @@ -0,0 +1,51 @@ +(* File reduced by coq-bug-finder from original input, then from 8752 lines to 735 lines, then from 735 lines to 310 lines, then from 228 lines to 105 lines, then from 98 lines to 41 lines *) +(* coqc version trunk (September 2014) compiled on Sep 6 2014 6:15:6 with OCaml 4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (3ea6d6888105edd5139ae0a4d8f8ecdb586aff6c) *) +Notation idmap := (fun x => x). +Axiom path_forall : forall {A : Type} {P : A -> Type} (f g : forall x : A, P x), (forall x, f x = g x) -> f = g. +Local Set Primitive Projections. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Bind Scope category_scope with PreCategory. +Set Implicit Arguments. +Delimit Scope functor_scope with functor. +Record Functor (C D : PreCategory) := {}. +Definition opposite (C : PreCategory) : PreCategory := @Build_PreCategory C (fun s d => morphism C d s). +Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope. +Definition oppositeF C D (F : Functor C D) : Functor C^op D^op := Build_Functor (C^op) (D^op). +Local Notation "F ^op" := (oppositeF F) (at level 3, format "F ^op") : functor_scope. +Axiom oppositeF_involutive : forall C D (F : Functor C D), ((F^op)^op)%functor = F. +Local Open Scope functor_scope. +Goal forall C D : PreCategory, + (fun c : Functor C^op D^op => (c^op)^op) = idmap. + intros. + exact (path_forall (fun F : Functor C^op D^op => (F^op)^op) _ (@oppositeF_involutive _ _)). + Undo. + Unset Printing Notations. + Set Debug Unification. +(* Check (eq_refl : Build_PreCategory (opposite D).(object) *) +(* (fun s d : (opposite D).(object) => *) +(* (opposite D).(morphism) d s) = *) +(* @Build_PreCategory D (fun s d => morphism D d s)). *) +(* opposite D). *) + exact (path_forall (fun F => (F^op)^op) _ (@oppositeF_involutive _ _)). +Qed. + (* Toplevel input, characters 22-101: +Error: +In environment +C : PreCategory +D : PreCategory +The term + "path_forall + (fun F : Functor (opposite C) (opposite D) => oppositeF (oppositeF F)) + (fun F : Functor (opposite C) (opposite D) => F) + (oppositeF_involutive (D:=opposite D))" has type + "eq (fun F : Functor (opposite C) (opposite D) => oppositeF (oppositeF F)) + (fun F : Functor (opposite C) (opposite D) => F)" +while it is expected to have type + "eq (fun c : Functor (opposite C) (opposite D) => oppositeF (oppositeF c)) + (fun x : Functor (opposite C) (opposite D) => x)" +(cannot unify "{| + object := opposite D; + morphism := fun s d : opposite D => morphism (opposite D) d s |}" +and "opposite D"). + *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3596.v b/test-suite/bugs/closed/3596.v new file mode 100644 index 00000000..d6c1c949 --- /dev/null +++ b/test-suite/bugs/closed/3596.v @@ -0,0 +1,18 @@ +Set Implicit Arguments. +Record foo := { fx : nat }. +Set Primitive Projections. +Record bar := { bx : nat }. +Definition Foo (f : foo) : f = f. + destruct f as [fx]; destruct fx; admit. +Defined. +Definition Bar (b : bar) : b = b. + destruct b as [fx]; destruct fx; admit. +Defined. +Goal forall f b, Bar b = Bar b -> Foo f = Foo f. + intros f b. + destruct f, b. + simpl. + Fail progress unfold Bar. (* success *) + Fail progress unfold Foo. (* failed to progress *) + reflexivity. +Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/3616.v b/test-suite/bugs/closed/3616.v new file mode 100644 index 00000000..68870026 --- /dev/null +++ b/test-suite/bugs/closed/3616.v @@ -0,0 +1,3 @@ +(* Was failing from April 2014 to September 2014 because of injection *) +Goal forall P e es t, (e :: es = existT P tt t :: es)%list -> True. +inversion 1. diff --git a/test-suite/bugs/closed/3618.v b/test-suite/bugs/closed/3618.v new file mode 100644 index 00000000..dc560ad5 --- /dev/null +++ b/test-suite/bugs/closed/3618.v @@ -0,0 +1,103 @@ +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Notation "x = y" := (@paths _ x y) : type_scope. +Definition concat {A} {x y z : A} : x = y -> y = z -> x = z. Admitted. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x. Admitted. +Notation "p @ q" := (concat p q) (at level 20). +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y. Admitted. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y. Admitted. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : forall x, f (equiv_inv x) = x; + eissect : forall x, equiv_inv (f x) = x +}. + +Class Contr_internal (A : Type). + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. +Definition istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A) +: IsTrunc n (x = y). +Admitted. + +Hint Extern 4 (IsTrunc _ (_ = _)) => eapply @istrunc_paths : typeclass_instances. + +Class Funext. + +Instance isequiv_compose A B C f g `{IsEquiv A B f} `{IsEquiv B C g} + : IsEquiv (compose g f) | 1000. +Admitted. + +Section IsEquivHomotopic. + Context (A B : Type) `(f : A -> B) `(g : A -> B) `{IsEquiv A B f} (h : forall x:A, f x = g x). + Let sect := (fun b:B => inverse (h (@equiv_inv _ _ f _ b)) @ @eisretr _ _ f _ b). + Let retr := (fun a:A => inverse (ap (@equiv_inv _ _ f _) (h a)) @ @eissect _ _ f _ a). + Global Instance isequiv_homotopic : IsEquiv g | 10000 + := ( BuildIsEquiv _ _ g (@equiv_inv _ _ f _) sect retr). +End IsEquivHomotopic. + +Instance trunc_succ A n `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. Admitted. + +Global Instance trunc_forall A n `{P : A -> Type} `{forall a, IsTrunc n (P a)} + : IsTrunc n (forall a, P a) | 100. +Admitted. + +Instance trunc_prod A B n `{IsTrunc n A} `{IsTrunc n B} : IsTrunc n (A * B) | 100. +Admitted. + +Global Instance trunc_arrow n {A B : Type} `{IsTrunc n B} : IsTrunc n (A -> B) | 100. +Admitted. + +Instance isequiv_pr1_contr {A} {P : A -> Type} `{forall a, IsTrunc minus_two (P a)} +: IsEquiv (@projT1 A P) | 100. +Admitted. + +Instance trunc_sigma n A `{P : A -> Type} `{IsTrunc n A} `{forall a, IsTrunc n (P a)} +: IsTrunc n (sigT P) | 100. +Admitted. + +Global Instance trunc_trunc `{Funext} A m n : IsTrunc (trunc_S n) (IsTrunc m A) | 0. +Admitted. + +Definition BiInv {A B} (f : A -> B) : Type +:= ( {g : B -> A & forall x, g (f x) = x} * {h : B -> A & forall x, f (h x) = x}). + +Global Instance isprop_biinv {A B} (f : A -> B) : IsTrunc (trunc_S minus_two) (BiInv f) | 0. +Admitted. + +Instance isequiv_path {A B : Type} (p : A = B) +: IsEquiv (transport (fun X:Type => X) p) | 0. +Admitted. + +Class ReflectiveSubuniverse_internal := + { inO_internal : Type -> Type ; + O : Type -> Type ; + O_unit : forall T, T -> O T }. + +Class ReflectiveSubuniverse := + ReflectiveSubuniverse_wrap : Funext -> ReflectiveSubuniverse_internal. +Global Existing Instance ReflectiveSubuniverse_wrap. + +Class inO {fs : Funext} {subU : ReflectiveSubuniverse} (T : Type) := + isequiv_inO : inO_internal T. + +Global Instance hprop_inO {fs : Funext} {subU : ReflectiveSubuniverse} (T : Type) : IsTrunc (trunc_S minus_two) (inO T) . +Admitted. + +(* To avoid looping class resolution *) +Hint Mode IsEquiv - - + : typeclass_instances. + +Fail Definition equiv_O_rectnd {fs : Funext} {subU : ReflectiveSubuniverse} + (P Q : Type) {Q_inO : inO_internal Q} +: IsEquiv (fun f : O P -> P => compose f (O_unit P)) := _. \ No newline at end of file diff --git a/test-suite/bugs/closed/3623.v b/test-suite/bugs/closed/3623.v new file mode 100644 index 00000000..202b9001 --- /dev/null +++ b/test-suite/bugs/closed/3623.v @@ -0,0 +1,4 @@ +Require Import List. +Goal (1 :: 2 :: nil) ++ (3::nil) = (1::2::3::nil). +change (@app nat (?a :: ?b) ?c) with (a :: @app nat b c). +Abort. diff --git a/test-suite/bugs/closed/3624.v b/test-suite/bugs/closed/3624.v new file mode 100644 index 00000000..a05d5eb2 --- /dev/null +++ b/test-suite/bugs/closed/3624.v @@ -0,0 +1,11 @@ +Set Implicit Arguments. +Module NonPrim. + Class foo (m : Set) := { pf : m = m }. + Notation pf' m := (pf (m := m)). +End NonPrim. + +Module Prim. + Set Primitive Projections. + Class foo (m : Set) := { pf : m = m }. + Notation pf' m := (pf (m:=m)). (* Wrong argument name: m. *) +End Prim. \ No newline at end of file diff --git a/test-suite/bugs/closed/3625.v b/test-suite/bugs/closed/3625.v new file mode 100644 index 00000000..3d30b62f --- /dev/null +++ b/test-suite/bugs/closed/3625.v @@ -0,0 +1,11 @@ +Set Implicit Arguments. +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. + +Goal forall x y : prod Set Set, x.(@fst _ _) = y.(@fst _ _). + intros. + refine (f_equal _ _). + Undo. + apply f_equal. + admit. +Qed. diff --git a/test-suite/bugs/closed/3628.v b/test-suite/bugs/closed/3628.v new file mode 100644 index 00000000..4001cf7c --- /dev/null +++ b/test-suite/bugs/closed/3628.v @@ -0,0 +1,9 @@ +Module NonPrim. + Class AClass := { x : Set }. + Arguments x {AClass}. +End NonPrim. +Module Prim. + Set Primitive Projections. + Class AClass := { x : Set }. + Arguments x {AClass}. +End Prim. diff --git a/test-suite/bugs/closed/3633.v b/test-suite/bugs/closed/3633.v new file mode 100644 index 00000000..6a952377 --- /dev/null +++ b/test-suite/bugs/closed/3633.v @@ -0,0 +1,10 @@ +Set Typeclasses Strict Resolution. +Class Contr (A : Type) := { center : A }. +Definition foo {A} `{Contr A} : A. +Proof. + apply center. + Undo. + (* Ensure the constraints are solved independently, otherwise a frozen ?A + makes a search for Contr ?A fail when finishing to apply (fun x => x) *) + apply (fun x => x), center. +Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/3637.v b/test-suite/bugs/closed/3637.v new file mode 100644 index 00000000..868f45c8 --- /dev/null +++ b/test-suite/bugs/closed/3637.v @@ -0,0 +1,11 @@ + +Set Implicit Arguments. +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. +Goal forall x y : prod Set Set, fst x = fst y. + intros. + lazymatch goal with + | [ |- context[@fst ?A ?B] ] => pose (@fst A B) as fst'; + progress change (@fst Set Set) with fst' +end. +Abort. diff --git a/test-suite/bugs/closed/3638.v b/test-suite/bugs/closed/3638.v new file mode 100644 index 00000000..70144174 --- /dev/null +++ b/test-suite/bugs/closed/3638.v @@ -0,0 +1,25 @@ +(* File reduced by coq-bug-finder from original input, then from 7593 lines to 243 lines, then from 256 lines to 102 lines, then from 104 lines to 28 lines *) +(* coqc version trunk (September 2014) compiled on Sep 17 2014 0:22:30 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d34e1eed232c84590ddb80d70db9f7f7cf13584a) *) +Set Primitive Projections. +Set Implicit Arguments. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Class UnitSubuniverse := { O : Type -> Type ; O_unit : forall T, T -> O T }. +Class ReflectiveSubuniverse := { rsubu_usubu : UnitSubuniverse ; O_rectnd : forall {P Q : Type} (f : P -> Q), O P -> Q }. +Global Existing Instance rsubu_usubu. +Context {subU : ReflectiveSubuniverse}. +Goal forall (A B : Type) (x : O A * O B) (x0 : B), + { g : _ & O_rectnd (fun z : A * B => (O_unit (fst z), O_unit (snd z))) + (O_rectnd (fun a : A => O_unit (a, x0)) (fst x)) = + g x0 }. + eexists. + Show Existentials. Set Printing Existential Instances. + match goal with + | [ |- context[?e] ] => is_evar e; let e' := fresh "e'" in set (e' := e) + end. + + +(* Toplevel input, characters 15-114: +Anomaly: Bad recursive type. Please report. *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3640.v b/test-suite/bugs/closed/3640.v new file mode 100644 index 00000000..bdbfbb15 --- /dev/null +++ b/test-suite/bugs/closed/3640.v @@ -0,0 +1,31 @@ +(* File reduced by coq-bug-finder from original input, then from 14990 lines to 70 lines, then from 44 lines to 29 lines *) +(* coqc version trunk (September 2014) compiled on Sep 17 2014 0:22:30 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d34e1eed232c84590ddb80d70db9f7f7cf13584a) *) +Set Primitive Projections. +Set Implicit Arguments. +Record sigT {A} P := existT { pr1 : A ; pr2 : P pr1 }. +Notation "{ x : A & P }" := (sigT (A := A) (fun x : A => P)) : type_scope. +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'"). +Notation "x .2" := (pr2 x) (at level 3, format "x '.2'"). +Record Equiv A B := { equiv_fun :> A -> B }. +Notation "A <~> B" := (Equiv A B) (at level 85). +Inductive Bool : Type := true | false. +Definition negb (b : Bool) := if b then false else true. +Axiom eval_bool_isequiv : forall (f : Bool -> Bool), f false = negb (f true). +Lemma bool_map_equiv_not_idmap (f : { f : Bool <~> Bool & ~(forall x, f x = x) }) +: forall b, ~(f.1 b = b). +Proof. + intro b. + intro H''. + apply f.2. + intro b'. + pose proof (eval_bool_isequiv f.1) as H. + destruct b', b. + Fail match type of H with + | _ = negb (f.1 true) => fail 1 "no f.1 true" + end. (* Error: No matching clauses for match. *) + destruct (f.1 true). + simpl in *. + Fail match type of H with + | _ = negb ?T => unify T (f.1 true); fail 1 "still has f.1 true" + end. (* Error: Tactic failure: still has f.1 true. *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3641.v b/test-suite/bugs/closed/3641.v new file mode 100644 index 00000000..f47f64ea --- /dev/null +++ b/test-suite/bugs/closed/3641.v @@ -0,0 +1,21 @@ +(* File reduced by coq-bug-finder from original input, then from 7593 lines to 243 lines, then from 256 lines to 102 lines, then from\ + 104 lines to 28 lines *) +(* coqc version trunk (September 2014) compiled on Sep 17 2014 0:22:30 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d34e1eed232c84590ddb80d70db9f7f7cf13584a) *) +Set Implicit Arguments. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Class UnitSubuniverse := { O : Type -> Type ; O_unit : forall T, T -> O T }. +Class ReflectiveSubuniverse := { rsubu_usubu : UnitSubuniverse ; O_rectnd : forall {P Q : Type} (f : P -> Q), O P -> Q }. +Global Existing Instance rsubu_usubu. +Context {subU : ReflectiveSubuniverse}. +Goal forall (A B : Type) (x : O A * O B) (x0 : B), + { g : _ & O_rectnd (fun z : A * B => (O_unit (fst z), O_unit (snd z))) + (O_rectnd (fun a : A => O_unit (a, x0)) (fst x)) = + g x0 }. + eexists. + match goal with + | [ |- context[?e] ] => is_evar e; let e' := fresh "e'" in pose (e' := e) + end. + Fail change ?g with e'. (* Stack overflow *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3647.v b/test-suite/bugs/closed/3647.v new file mode 100644 index 00000000..cd542c8a --- /dev/null +++ b/test-suite/bugs/closed/3647.v @@ -0,0 +1,652 @@ +Require Coq.Setoids.Setoid. + +Axiom BITS : nat -> Set. +Definition n7 := 7. +Definition n15 := 15. +Definition n31 := 31. +Notation n8 := (S n7). +Notation n16 := (S n15). +Notation n32 := (S n31). +Inductive OpSize := OpSize1 | OpSize2 | OpSize4 . +Definition VWORD s := BITS (match s with OpSize1 => n8 | OpSize2 => n16 | OpSize4 => n32 end). +Definition BYTE := VWORD OpSize1. +Definition WORD := VWORD OpSize2. +Definition DWORD := VWORD OpSize4. +Ltac subst_body := + repeat match goal with + | [ H := _ |- _ ] => subst H + end. +Import Coq.Setoids.Setoid. +Class Equiv (A : Type) := equiv : relation A. +Infix "===" := equiv (at level 70, no associativity). +Class type (A : Type) {e : Equiv A} := eq_equiv : Equivalence equiv. +Definition setoid_resp {T T'} (f : T -> T') `{e : type T} `{e' : type T'} := forall x y, x === y -> f x === f y. +Record morphism T T' `{e : type T} `{e' : type T'} := + mkMorph { + morph :> T -> T'; + morph_resp : setoid_resp morph}. +Implicit Arguments mkMorph [T T' e e0 e' e1]. +Infix "-s>" := morphism (at level 45, right associativity). +Section Morphisms. + Context {S T U V} `{eS : type S} `{eT : type T} `{eU : type U} `{eV : type V}. + Global Instance morph_equiv : Equiv (S -s> T). + admit. + Defined. + + Global Instance morph_type : type (S -s> T). + admit. + Defined. + + Program Definition mcomp (f: T -s> U) (g: S -s> T) : (S -s> U) := + mkMorph (fun x => f (g x)) _. + Next Obligation. + admit. + Defined. + +End Morphisms. + +Infix "<<" := mcomp (at level 35). + +Section MorphConsts. + Context {S T U V} `{eS : type S} `{eT : type T} `{eU : type U} `{eV : type V}. + + Definition lift2s (f : S -> T -> U) p q : (S -s> T -s> U) := + mkMorph (fun x => mkMorph (f x) (p x)) q. + +End MorphConsts. +Instance Equiv_PropP : Equiv Prop. +admit. +Defined. + +Section SetoidProducts. + Context {A B : Type} `{eA : type A} `{eB : type B}. + Global Instance Equiv_prod : Equiv (A * B). + admit. + Defined. + + Global Instance type_prod : type (A * B). + admit. + Defined. + + Program Definition mfst : (A * B) -s> A := + mkMorph (fun p => fst p) _. + Next Obligation. + admit. + Defined. + + Program Definition msnd : (A * B) -s> B := + mkMorph (fun p => snd p) _. + Next Obligation. + admit. + Defined. + + Context {C} `{eC : type C}. + + Program Definition mprod (f: C -s> A) (g: C -s> B) : C -s> (A * B) := + mkMorph (fun c => (f c, g c)) _. + Next Obligation. + admit. + Defined. + +End SetoidProducts. + +Section IndexedProducts. + + Record ttyp := {carr :> Type; eqc : Equiv carr; eqok : type carr}. + Global Instance ttyp_proj_eq {A : ttyp} : Equiv A. + admit. + Defined. + Global Instance ttyp_proj_prop {A : ttyp} : type A. + admit. + Defined. + Context {I : Type} {P : I -> ttyp}. + + Global Program Instance Equiv_prodI : Equiv (forall i, P i) := + fun p p' : forall i, P i => (forall i : I, @equiv _ (eqc _) (p i) (p' i)). + + Global Instance type_prodI : type (forall i, P i). + admit. + Defined. + + Program Definition mprojI (i : I) : (forall i, P i) -s> P i := + mkMorph (fun X => X i) _. + Next Obligation. + admit. + Defined. + + Context {C : Type} `{eC : type C}. + + Program Definition mprodI (f : forall i, C -s> P i) : C -s> (forall i, P i) := + mkMorph (fun c i => f i c) _. + Next Obligation. + admit. + Defined. + +End IndexedProducts. + +Section Exponentials. + + Context {A B C D} `{eA : type A} `{eB : type B} `{eC : type C} `{eD : type D}. + + Program Definition comps : (B -s> C) -s> (A -s> B) -s> A -s> C := + lift2s (fun f g => f << g) _ _. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + + Program Definition muncurry (f : A -s> B -s> C) : A * B -s> C := + mkMorph (fun p => f (fst p) (snd p)) _. + Next Obligation. + admit. + Defined. + + Program Definition mcurry (f : A * B -s> C) : A -s> B -s> C := + lift2s (fun a b => f (a, b)) _ _. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + + Program Definition meval : (B -s> A) * B -s> A := + mkMorph (fun p => fst p (snd p)) _. + Next Obligation. + admit. + Defined. + + Program Definition mid : A -s> A := mkMorph (fun x => x) _. + Next Obligation. + admit. + Defined. + + Program Definition mconst (b : B) : A -s> B := mkMorph (fun _ => b) _. + Next Obligation. + admit. + Defined. + +End Exponentials. + +Inductive empty : Set := . +Instance empty_Equiv : Equiv empty. +admit. +Defined. +Instance empty_type : type empty. +admit. +Defined. + +Section Initials. + Context {A} `{eA : type A}. + + Program Definition mzero_init : empty -s> A := mkMorph (fun x => match x with end) _. + Next Obligation. + admit. + Defined. + +End Initials. + +Section Subsetoid. + + Context {A} `{eA : type A} {P : A -> Prop}. + Global Instance subset_Equiv : Equiv {a : A | P a}. + admit. + Defined. + Global Instance subset_type : type {a : A | P a}. + admit. + Defined. + + Program Definition mforget : {a : A | P a} -s> A := + mkMorph (fun x => x) _. + Next Obligation. + admit. + Defined. + + Context {B} `{eB : type B}. + Program Definition minherit (f : B -s> A) (HB : forall b, P (f b)) : B -s> {a : A | P a} := + mkMorph (fun b => exist P (f b) (HB b)) _. + Next Obligation. + admit. + Defined. + +End Subsetoid. + +Section Option. + + Context {A} `{eA : type A}. + Global Instance option_Equiv : Equiv (option A). + admit. + Defined. + + Global Instance option_type : type (option A). + admit. + Defined. + +End Option. + +Section OptDefs. + Context {A B} `{eA : type A} `{eB : type B}. + + Program Definition msome : A -s> option A := mkMorph (fun a => Some a) _. + Next Obligation. + admit. + Defined. + + Program Definition moptionbind (f : A -s> option B) : option A -s> option B := + mkMorph (fun oa => match oa with None => None | Some a => f a end) _. + Next Obligation. + admit. + Defined. + +End OptDefs. + +Generalizable Variables Frm. + +Class ILogicOps Frm := { + lentails: relation Frm; + ltrue: Frm; + lfalse: Frm; + limpl: Frm -> Frm -> Frm; + land: Frm -> Frm -> Frm; + lor: Frm -> Frm -> Frm; + lforall: forall {T}, (T -> Frm) -> Frm; + lexists: forall {T}, (T -> Frm) -> Frm + }. + +Infix "|--" := lentails (at level 79, no associativity). +Infix "//\\" := land (at level 75, right associativity). +Infix "\\//" := lor (at level 76, right associativity). +Infix "-->>" := limpl (at level 77, right associativity). +Notation "'Forall' x .. y , p" := + (lforall (fun x => .. (lforall (fun y => p)) .. )) (at level 78, x binder, y binder, right associativity). +Notation "'Exists' x .. y , p" := + (lexists (fun x => .. (lexists (fun y => p)) .. )) (at level 78, x binder, y binder, right associativity). + +Class ILogic Frm {ILOps: ILogicOps Frm} := { + lentailsPre:> PreOrder lentails; + ltrueR: forall C, C |-- ltrue; + lfalseL: forall C, lfalse |-- C; + lforallL: forall T x (P: T -> Frm) C, P x |-- C -> lforall P |-- C; + lforallR: forall T (P: T -> Frm) C, (forall x, C |-- P x) -> C |-- lforall P; + lexistsL: forall T (P: T -> Frm) C, (forall x, P x |-- C) -> lexists P |-- C; + lexistsR: forall T x (P: T -> Frm) C, C |-- P x -> C |-- lexists P; + landL1: forall P Q C, P |-- C -> P //\\ Q |-- C; + landL2: forall P Q C, Q |-- C -> P //\\ Q |-- C; + lorR1: forall P Q C, C |-- P -> C |-- P \\// Q; + lorR2: forall P Q C, C |-- Q -> C |-- P \\// Q; + landR: forall P Q C, C |-- P -> C |-- Q -> C |-- P //\\ Q; + lorL: forall P Q C, P |-- C -> Q |-- C -> P \\// Q |-- C; + landAdj: forall P Q C, C |-- (P -->> Q) -> C //\\ P |-- Q; + limplAdj: forall P Q C, C //\\ P |-- Q -> C |-- (P -->> Q) + }. +Hint Extern 0 (?x |-- ?x) => reflexivity. + +Section ILogicExtra. + Context `{IL: ILogic Frm}. + Definition lpropand (p: Prop) Q := Exists _: p, Q. + Definition lpropimpl (p: Prop) Q := Forall _: p, Q. + +End ILogicExtra. + +Infix "/\\" := lpropand (at level 75, right associativity). +Infix "->>" := lpropimpl (at level 77, right associativity). + +Section ILogic_Fun. + Context (T: Type) `{TType: type T}. + Context `{IL: ILogic Frm}. + + Record ILFunFrm := mkILFunFrm { + ILFunFrm_pred :> T -> Frm; + ILFunFrm_closed: forall t t': T, t === t' -> + ILFunFrm_pred t |-- ILFunFrm_pred t' + }. + + Notation "'mk'" := @mkILFunFrm. + + Program Definition ILFun_Ops : ILogicOps ILFunFrm := {| + lentails P Q := forall t:T, P t |-- Q t; + ltrue := mk (fun t => ltrue) _; + lfalse := mk (fun t => lfalse) _; + limpl P Q := mk (fun t => P t -->> Q t) _; + land P Q := mk (fun t => P t //\\ Q t) _; + lor P Q := mk (fun t => P t \\// Q t) _; + lforall A P := mk (fun t => Forall a, P a t) _; + lexists A P := mk (fun t => Exists a, P a t) _ + |}. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + +End ILogic_Fun. + +Implicit Arguments ILFunFrm [[ILOps] [e]]. +Implicit Arguments mkILFunFrm [T Frm ILOps]. + +Program Definition ILFun_eq {T R} {ILOps: ILogicOps R} {ILogic: ILogic R} (P : T -> R) : + @ILFunFrm T _ R ILOps := + @mkILFunFrm T eq R ILOps P _. +Next Obligation. + admit. +Defined. + +Instance ILogicOps_Prop : ILogicOps Prop | 2 := {| + lentails P Q := (P : Prop) -> Q; + ltrue := True; + lfalse := False; + limpl P Q := P -> Q; + land P Q := P /\ Q; + lor P Q := P \/ Q; + lforall T F := forall x:T, F x; + lexists T F := exists x:T, F x + |}. + +Instance ILogic_Prop : ILogic Prop. +admit. +Defined. + +Section FunEq. + Context A `{eT: type A}. + + Global Instance FunEquiv {T} : Equiv (T -> A) := { + equiv P Q := forall a, P a === Q a + }. +End FunEq. + +Section SepAlgSect. + Class SepAlgOps T `{eT : type T}:= { + sa_unit : T; + + sa_mul : T -> T -> T -> Prop + }. + + Class SepAlg T `{SAOps: SepAlgOps T} : Type := { + sa_mul_eqL a b c d : sa_mul a b c -> c === d -> sa_mul a b d; + sa_mul_eqR a b c d : sa_mul a b c -> sa_mul a b d -> c === d; + sa_mon a b c : a === b -> sa_mul a c === sa_mul b c; + sa_mulC a b : sa_mul a b === sa_mul b a; + sa_mulA a b c : forall bc abc, sa_mul a bc abc -> sa_mul b c bc -> + exists ac, sa_mul b ac abc /\ sa_mul a c ac; + sa_unitI a : sa_mul a sa_unit a + }. + +End SepAlgSect. + +Section BILogic. + + Class BILOperators (A : Type) := { + empSP : A; + sepSP : A -> A -> A; + wandSP : A -> A -> A + }. + +End BILogic. + +Notation "a '**' b" := (sepSP a b) + (at level 75, right associativity). + +Section BISepAlg. + Context {A} `{sa : SepAlg A}. + Context {B} `{IL: ILogic B}. + + Program Instance SABIOps: BILOperators (ILFunFrm A B) := { + empSP := mkILFunFrm e (fun x => sa_unit === x /\\ ltrue) _; + sepSP P Q := mkILFunFrm e (fun x => Exists x1, Exists x2, sa_mul x1 x2 x /\\ + P x1 //\\ Q x2) _; + wandSP P Q := mkILFunFrm e (fun x => Forall x1, Forall x2, sa_mul x x1 x2 ->> + P x1 -->> Q x2) _ + }. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + Next Obligation. + admit. + Defined. + +End BISepAlg. + +Set Implicit Arguments. + +Definition Chan := WORD. +Definition Data := BYTE. + +Inductive Action := +| Out (c:Chan) (d:Data) +| In (c:Chan) (d:Data). + +Definition Actions := list Action. + +Instance ActionsEquiv : Equiv Actions := { + equiv a1 a2 := a1 = a2 + }. + +Definition OPred := ILFunFrm Actions Prop. +Definition mkOPred (P : Actions -> Prop) : OPred. + admit. +Defined. + +Definition eq_opred s := mkOPred (fun s' => s === s'). +Definition empOP : OPred. + exact (eq_opred nil). +Defined. +Definition catOP (P Q: OPred) : OPred. + admit. +Defined. + +Class IsPointed (T : Type) := point : T. + +Generalizable All Variables. + +Notation IsPointed_OPred P := (IsPointed (exists x : Actions, (P : OPred) x)). + +Record PointedOPred := mkPointedOPred { + OPred_pred :> OPred; + OPred_inhabited: IsPointed_OPred OPred_pred + }. + +Existing Instance OPred_inhabited. + +Canonical Structure default_PointedOPred O `{IsPointed_OPred O} : PointedOPred + := {| OPred_pred := O ; OPred_inhabited := _ |}. +Instance IsPointed_eq_opred x : IsPointed_OPred (eq_opred x). +admit. +Defined. +Instance IsPointed_catOP `{IsPointed_OPred P, IsPointed_OPred Q} : IsPointed_OPred (catOP P Q). +admit. +Defined. + +Definition Flag := BITS 5. +Definition OF: Flag. + admit. +Defined. + +Inductive FlagVal := mkFlag (b: bool) | FlagUnspecified. +Coercion mkFlag : bool >-> FlagVal. +Inductive NonSPReg := EAX | EBX | ECX | EDX | ESI | EDI | EBP. + +Inductive Reg := nonSPReg (r: NonSPReg) | ESP. + +Inductive AnyReg := regToAnyReg (r: Reg) | EIP. + +Inductive BYTEReg := AL|BL|CL|DL|AH|BH|CH|DH. + +Inductive WORDReg := mkWordReg (r:Reg). +Definition PState : Type. +admit. +Defined. + +Instance PStateEquiv : Equiv PState. +admit. +Defined. + +Instance PStateType : type PState. +admit. +Defined. + +Instance PStateSepAlgOps: SepAlgOps PState. +admit. +Defined. +Definition SPred : Type. +exact (ILFunFrm PState Prop). +Defined. + +Local Existing Instance ILFun_Ops. +Local Existing Instance SABIOps. +Axiom BYTEregIs : BYTEReg -> BYTE -> SPred. + +Inductive RegOrFlag := +| RegOrFlagDWORD :> AnyReg -> RegOrFlag +| RegOrFlagWORD :> WORDReg -> RegOrFlag +| RegOrFlagBYTE :> BYTEReg -> RegOrFlag +| RegOrFlagF :> Flag -> RegOrFlag. + +Definition RegOrFlag_target rf := + match rf with + | RegOrFlagDWORD _ => DWORD + | RegOrFlagWORD _ => WORD + | RegOrFlagBYTE _ => BYTE + | RegOrFlagF _ => FlagVal + end. + +Inductive Condition := +| CC_O | CC_B | CC_Z | CC_BE | CC_S | CC_P | CC_L | CC_LE. + +Section ILSpecSect. + + Axiom spec : Type. + Global Instance ILOps: ILogicOps spec | 2. + admit. + Defined. + +End ILSpecSect. + +Axiom parameterized_basic : forall {T_OPred} {proj : T_OPred -> OPred} {T} (P : SPred) (c : T) (O : OPred) (Q : SPred), spec. +Global Notation loopy_basic := (@parameterized_basic PointedOPred OPred_pred _). + +Axiom program : Type. + +Axiom ConditionIs : forall (cc : Condition) (cv : RegOrFlag_target OF), SPred. + +Axiom foldl : forall {T R}, (R -> T -> R) -> R -> list T -> R. +Axiom nth : forall {T}, T -> list T -> nat -> T. +Axiom while : forall (ptest: program) + (cond: Condition) (value: bool) + (pbody: program), program. + +Lemma while_rule_ind {quantT} + {ptest} {cond : Condition} {value : bool} {pbody} + {S} + {transition_body : quantT -> quantT} + {P : quantT -> SPred} {Otest : quantT -> OPred} {Obody : quantT -> OPred} {O : quantT -> PointedOPred} + {O_after_test : quantT -> PointedOPred} + {I_state : quantT -> bool -> SPred} + {I_logic : quantT -> bool -> bool} + {Q : quantT -> SPred} + (Htest : S |-- (Forall (x : quantT), + (loopy_basic (P x) + ptest + (Otest x) + (Exists b, I_logic x b = true /\\ I_state x b ** ConditionIs cond b)))) + (Hbody : S |-- (Forall (x : quantT), + (loopy_basic (I_logic x value = true /\\ I_state x value ** ConditionIs cond value) + pbody + (Obody x) + (P (transition_body x))))) + (H_after_test : forall x, catOP (Otest x) (O_after_test x) |-- O x) + (H_body_after_test : forall x, I_logic x value = true -> catOP (Obody x) (O (transition_body x)) |-- O_after_test x) + (H_empty : forall x, I_logic x (negb value) = true -> empOP |-- O_after_test x) + (Q_correct : forall x, I_logic x (negb value) = true /\\ I_state x (negb value) ** ConditionIs cond (negb value) |-- Q x) + (Q_safe : forall x, I_logic x value = true -> Q (transition_body x) |-- Q x) +: S |-- (Forall (x : quantT), + loopy_basic (P x) + (while ptest cond value pbody) + (O x) + (Q x)). +admit. +Defined. +Axiom behead : forall {T}, list T -> list T. +Axiom all : forall {T}, (T -> bool) -> list T -> bool. +Axiom all_behead : forall {T} (xs : list T) P, all P xs = true -> all P (behead xs) = true. +Instance IsPointed_foldlOP A B C f g (init : A * B) `{IsPointed_OPred (g init)} + `{forall a acc, IsPointed_OPred (g acc) -> IsPointed_OPred (g (f acc a))} + (ls : list C) +: IsPointed_OPred (g (foldl f init ls)). +admit. +Defined. +Goal forall (ptest : program) (cond : Condition) (value : bool) + (pbody : program) (T ioT : Type) (P : T -> SPred) + (I : T -> bool -> SPred) (accumulate : T -> ioT -> T) + (Otest Obody : T -> ioT -> PointedOPred) + (coq_test__is_finished : ioT -> bool) (S : spec) + (al : BYTE), + (forall (initial : T) (xs : list ioT) (x : ioT), + all (fun t : ioT => negb (coq_test__is_finished t)) xs = true -> + coq_test__is_finished x = true -> + S + |-- loopy_basic (P initial ** BYTEregIs AL al) ptest + (Otest initial (nth x xs 0)) + (I initial + (match coq_test__is_finished (nth x xs 0) with true => negb value | false => value end) ** + ConditionIs cond + (match coq_test__is_finished (nth x xs 0) with true => negb value | false => value end))) -> + (forall (initial : T) (xs : list ioT) (x : ioT), + all (fun t : ioT => negb (coq_test__is_finished t)) xs = true -> + xs <> nil -> + coq_test__is_finished x = true -> + S + |-- loopy_basic (I initial value ** ConditionIs cond value) pbody + (Obody initial (nth x xs 0)) + (P (accumulate initial (nth x xs 0)) ** BYTEregIs AL al)) -> + forall x : ioT, + coq_test__is_finished x = true -> + S + |-- Forall ixsp : {init_xs : T * list ioT & + all (fun t : ioT => negb (coq_test__is_finished t)) + (snd init_xs) = true}, + loopy_basic (P (fst (projT1 ixsp)) ** BYTEregIs AL al) + (while ptest cond value pbody) + (catOP + (snd + (foldl + (fun (xy : T * OPred) (v : ioT) => + (accumulate (fst xy) v, + catOP (catOP (Otest (fst xy) v) (Obody (fst xy) v)) + (snd xy))) (fst (projT1 ixsp), empOP) + (snd (projT1 ixsp)))) + (Otest (foldl accumulate (fst (projT1 ixsp)) (snd (projT1 ixsp))) + x)) + (I (foldl accumulate (fst (projT1 ixsp)) (snd (projT1 ixsp))) + (negb value) ** ConditionIs cond (negb value)). + intros. + eapply @while_rule_ind + with (I_logic := fun ixsp b => match (match (coq_test__is_finished (nth x (snd (projT1 ixsp)) 0)) with true => negb value | false => value end), b with true, true => true | false, false => true | _, _ => false end) + (Otest := fun ixsp => Otest (fst (projT1 ixsp)) (nth x (snd (projT1 ixsp)) 0)) + (Obody := fun ixsp => Obody (fst (projT1 ixsp)) (nth x (snd (projT1 ixsp)) 0)) + (I_state := fun ixsp => I (fst (projT1 ixsp))) + (transition_body := fun ixsp => let initial := fst (projT1 ixsp) in + let xs := snd (projT1 ixsp) in + existT _ (accumulate initial (nth x xs 0), behead xs) _) + (O_after_test := fun ixsp => let initial := fst (projT1 ixsp) in + let xs := snd (projT1 ixsp) in + match xs with | nil => default_PointedOPred empOP | _ => Obody initial (nth x xs 0) end); + simpl projT1; simpl projT2; simpl fst; simpl snd; clear; let H := fresh in assert (H : False) by (clear; admit); destruct H. + + Grab Existential Variables. + subst_body; simpl. + refine (all_behead (projT2 _)). diff --git a/test-suite/bugs/closed/3648.v b/test-suite/bugs/closed/3648.v new file mode 100644 index 00000000..ba6006ed --- /dev/null +++ b/test-suite/bugs/closed/3648.v @@ -0,0 +1,83 @@ +(* File reduced by coq-bug-finder from original input, then from 8808 lines to 424 lines, then from 432 lines to 196 lines, then from\ + 145 lines to 82 lines *) +(* coqc version trunk (September 2014) compiled on Sep 18 2014 21:0:5 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *) + +Reserved Infix "o" (at level 40, left associativity). +Global Set Primitive Projections. + +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. + +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g) + }. +Arguments identity {!C%category} / x%object : rename. + +Infix "o" := (@compose _ _ _ _) : morphism_scope. + +Local Open Scope morphism_scope. +Definition prodC (C D : PreCategory) : PreCategory. + refine (@Build_PreCategory + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) + * morphism D (snd s) (snd d))%type) + (fun x => (identity (fst x), identity (snd x))) + (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1))). +Defined. + +Local Infix "*" := prodC : category_scope. + +Delimit Scope functor_scope with functor. + +Record Functor (C D : PreCategory) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) + }. +Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. +Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. +Axiom cheat : forall {A}, A. +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. +Definition functor_category (C D : PreCategory) : PreCategory. + exact (@Build_PreCategory (Functor C D) + (@NaturalTransformation C D) cheat cheat). +Defined. + +Local Notation "C -> D" := (functor_category C D) : category_scope. +Variable C1 : PreCategory. +Variable C2 : PreCategory. +Variable D : PreCategory. + +Definition functor_object_of +: (C1 -> (C2 -> D))%category -> (C1 * C2 -> D)%category. +Proof. + intro F; hnf in F |- *. + refine (Build_Functor + (prodC C1 C2) D + (fun c1c2 => F (fst c1c2) (snd c1c2)) + (fun s d m => F (fst d) _1 (snd m) o (@morphism_of _ _ F _ _ (fst m)) (snd s)) + _). + intros. + rewrite identity_of. + cbn. + rewrite (identity_of _ _ F (fst x)). + Undo. +(* Toplevel input, characters 20-55: +Error: +Found no subterm matching "F _1 (identity (fst x))" in the current goal. *) + rewrite identity_of. (* Toplevel input, characters 15-34: +Error: +Found no subterm matching "morphism_of ?202 (identity ?203)" in the current goal. *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3652.v b/test-suite/bugs/closed/3652.v new file mode 100644 index 00000000..86e06137 --- /dev/null +++ b/test-suite/bugs/closed/3652.v @@ -0,0 +1,101 @@ +Require Setoid. +Require ZArith. +Import ZArith. + +Inductive Erasable(A : Set) : Prop := + erasable: A -> Erasable A. + +Arguments erasable [A] _. + +Hint Constructors Erasable. + +Scheme Erasable_elim := Induction for Erasable Sort Prop. + +Notation "## T" := (Erasable T) (at level 1, format "## T") : Erasable_scope. +Notation "# x" := (erasable x) (at level 1, format "# x") : Erasable_scope. +Open Scope Erasable_scope. + +Axiom Erasable_inj : forall {A : Set}{a b : A}, #a=#b -> a=b. + +Lemma Erasable_rw : forall (A: Set)(a b : A), (#a=#b) <-> (a=b). +Proof. + intros A a b. + split. + - apply Erasable_inj. + - congruence. +Qed. + +Open Scope Z_scope. +Opaque Z.mul. + +Infix "^" := Zpower_nat : Z_scope. + +Notation "f ; v <- x" := (let (v) := x in f) + (at level 199, left associativity) : Erasable_scope. +Notation "f ; < v" := (f ; v <- v) + (at level 199, left associativity) : Erasable_scope. +Notation "f |# v <- x" := (#f ; v <- x) + (at level 199, left associativity) : Erasable_scope. +Notation "f |# < v" := (#f ; < v) + (at level 199, left associativity) : Erasable_scope. + +Ltac name_evars id := + repeat match goal with |- context[?V] => + is_evar V; let H := fresh id in set (H:=V) in * end. + +Lemma Twoto0 : 2^0 = 1. +Proof. compute. reflexivity. Qed. + +Ltac ring_simplify' := rewrite ?Twoto0; ring_simplify. + +Definition mp2a1s(x : Z)(n : nat) := x * 2^n + (2^n-1). + +Hint Unfold mp2a1s. + +Definition zotval(n1s : nat)(is2 : bool)(next_value : Z) : Z := + 2 * mp2a1s next_value n1s + if is2 then 2 else 0. + +Inductive zot'(eis2 : ##bool)(value : ##Z) : Set := +| Zot'(is2 : bool) + (iseq : eis2=#is2) + {next_is2 : ##bool} + (ok : is2=true -> next_is2=#false) + {next_value : ##Z} + (n1s : nat) + (veq : value = (zotval n1s is2 next_value |# Prop. + +Lemma rule{T : Set}{x : T} : Q x <-> P x. admit. Qed. + +Goal forall (T : Set)(x : T), Q x <-> P x. +Proof. +intros T x. +setoid_rewrite rule. +reflexivity. +Qed. diff --git a/test-suite/bugs/closed/3654.v b/test-suite/bugs/closed/3654.v new file mode 100644 index 00000000..15277235 --- /dev/null +++ b/test-suite/bugs/closed/3654.v @@ -0,0 +1,7 @@ +Tactic Notation "mysimpl" "in" ne_hyp_list(hyps) := simpl in hyps. + +Goal 0+0=0->0+0=0->0=0. +intros H1 H2. +mysimpl in H1 H2. +match goal with H:0=0 |- _ => exact H end. +Qed. diff --git a/test-suite/bugs/closed/3656.v b/test-suite/bugs/closed/3656.v new file mode 100644 index 00000000..cbd773d0 --- /dev/null +++ b/test-suite/bugs/closed/3656.v @@ -0,0 +1,53 @@ +Module A. + Set Primitive Projections. + Record hSet : Type := BuildhSet { setT : Type; iss : True }. + Ltac head_hnf_under_binders x := + match eval hnf in x with + | ?f _ => head_hnf_under_binders f + | (fun y => ?f y) => head_hnf_under_binders f + | ?y => y + end. +Goal forall s : hSet, True. +intros. +let x := head_hnf_under_binders setT in pose x. + +set (foo := eq_refl (@setT )). generalize foo. simpl. cbn. +Abort. +End A. + +Module A'. +Set Universe Polymorphism. + Set Primitive Projections. +Record hSet (A : Type) : Type := BuildhSet { setT : Type; iss : True }. +Ltac head_hnf_under_binders x := + match eval compute in x with + | ?f _ => head_hnf_under_binders f + | (fun y => ?f y) => head_hnf_under_binders f + | ?y => y + end. +Goal forall s : @hSet nat, True. +intros. +let x := head_hnf_under_binders setT in pose x. + +set (foo := eq_refl (@setT nat)). generalize foo. simpl. cbn. +Abort. +End A'. + +Set Primitive Projections. +Record hSet : Type := BuildhSet { setT : Type; iss : True }. +Ltac head_hnf_under_binders x := + match eval hnf in x with + | ?f _ => head_hnf_under_binders f + | (fun y => ?f y) => head_hnf_under_binders f + | ?y => y + end. +Goal setT = setT. + progress unfold setT. (* should not succeed *) + match goal with + | |- (fun h => setT h) = (fun h => setT h) => fail 1 "should not eta-expand" + | _ => idtac + end. (* should not fail *) +Abort. + +Goal forall h, setT h = setT h. +Proof. intro. progress unfold setT. diff --git a/test-suite/bugs/closed/3657.v b/test-suite/bugs/closed/3657.v new file mode 100644 index 00000000..778fdab1 --- /dev/null +++ b/test-suite/bugs/closed/3657.v @@ -0,0 +1,12 @@ +(* Check typing of replaced objects in change - even though the failure + was already a proper error message (but with a helpless content) *) + +Class foo {A} {a : A} := { bar := a; baz : bar = bar }. +Arguments bar {_} _ {_}. +Instance: forall A a, @foo A a. +intros; constructor. +abstract reflexivity. +Defined. +Goal @bar _ Set _ = (@bar _ (fun _ : Set => Set) _) nat. +Proof. + Fail change (bar (fun _ : Set => Set)) with (bar Set). diff --git a/test-suite/bugs/closed/3658.v b/test-suite/bugs/closed/3658.v new file mode 100644 index 00000000..b1158b9a --- /dev/null +++ b/test-suite/bugs/closed/3658.v @@ -0,0 +1,74 @@ +(* File reduced by coq-bug-finder from original input, then from 12178 lines to 457 lines, then from 500 lines to 147 lines, then from 175 lines to 56 lines *) +(* coqc version trunk (September 2014) compiled on Sep 21 2014 16:34:4 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (eaf864354c3fda9ddc1f03f0b1c7807b6fd44322) *) + +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y. +Module NonPrim. + Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center = y) }. + Arguments center A {_} / . + Inductive trunc_index : Type := minus_two | trunc_S (_ : trunc_index). + Notation "-2" := minus_two (at level 0). + Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | -2 => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. + Notation Contr := (IsTrunc -2). + Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances. + Goal forall (H : Type) (H0 : H -> H -> Type) (H1 : Type) + (H2 : Contr H1) (H3 : H1) (H4 : H1 -> H) + (H5 : H0 (H4 (center H1)) (H4 H3)) + (H6 : H0 (H4 (center H1)) (H4 (center H1))), + transport (fun y : H => H0 (H4 (center H1)) y) (ap H4 (contr H3)) H6 = H5. + intros. + match goal with + | [ |- context[contr (center _)] ] => fail 1 "bad" + | _ => idtac + end. + match goal with + | [ H : _ |- _ ] => destruct (contr H) + end. + match goal with + | [ |- context[contr (center ?x)] ] => fail 1 "bad" x + | _ => idtac + end. + admit. + Defined. +End NonPrim. + +Module Prim. + Set Primitive Projections. + Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center = y) }. + Arguments center A {_} / . + Inductive trunc_index : Type := minus_two | trunc_S (_ : trunc_index). + Notation "-2" := minus_two (at level 0). + Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | -2 => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. + Notation Contr := (IsTrunc -2). + Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances. + Goal forall (H : Type) (H0 : H -> H -> Type) (H1 : Type) + (H2 : Contr H1) (H3 : H1) (H4 : H1 -> H) + (H5 : H0 (H4 (center H1)) (H4 H3)) + (H6 : H0 (H4 (center H1)) (H4 (center H1))), + transport (fun y : H => H0 (H4 (center H1)) y) (ap H4 (contr H3)) H6 = H5. + intros. + match goal with + | [ |- context[contr (center _)] ] => fail 1 "bad" + | _ => idtac + end. + match goal with + | [ H : _ |- _ ] => destruct (contr H) + end. + match goal with + | [ |- context[contr (center ?x)] ] => fail 1 "bad" x + | _ => idtac + end. (* Error: Tactic failure: bad H1. *) + admit. + Defined. +End Prim. \ No newline at end of file diff --git a/test-suite/bugs/closed/3660.v b/test-suite/bugs/closed/3660.v new file mode 100644 index 00000000..ed8964ce --- /dev/null +++ b/test-suite/bugs/closed/3660.v @@ -0,0 +1,27 @@ +Generalizable All Variables. +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. +Open Scope function_scope. +Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y. +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }. +Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. +Axiom IsHSet : Type -> Type. +Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} : IsEquiv (compose g f) | 1000. +admit. +Defined. +Set Primitive Projections. +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). +Global Instance isequiv_ap_setT X Y : IsEquiv (@ap _ _ setT X Y). +admit. +Defined. +Local Open Scope equiv_scope. +Axiom equiv_path : forall (A B : Type) (p : A = B), A <~> B. + +Goal forall (C D : hSet), IsEquiv (fun x : C = D => (equiv_path C D (ap setT x))). + intros. + change (IsEquiv (equiv_path C D o @ap _ _ setT C D)). + apply @isequiv_compose; [ | admit ]. + Set Typeclasses Debug. + typeclasses eauto. diff --git a/test-suite/bugs/closed/3661.v b/test-suite/bugs/closed/3661.v new file mode 100644 index 00000000..fdca49bc --- /dev/null +++ b/test-suite/bugs/closed/3661.v @@ -0,0 +1,88 @@ +(* File reduced by coq-bug-finder from original input, then from 11218 lines to 438 lines, then from 434 lines to 202 lines, then from 140 lines to 94 lines *) +(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *) +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Set Implicit Arguments. +Delimit Scope morphism_scope with morphism. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Bind Scope category_scope with PreCategory. +Local Open Scope morphism_scope. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) }. +Set Primitive Projections. +Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }. +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. +Unset Primitive Projections. +Class Isomorphic {C : PreCategory} s d := + { morphism_isomorphic :> morphism C s d; + isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic }. +Arguments morphism_inverse {C s d} m {_} / . +Local Notation "m ^-1" := (morphism_inverse m) (at level 3, format "m '^-1'") : morphism_scope. +Definition functor_category (C D : PreCategory) : PreCategory. + exact (@Build_PreCategory (Functor C D) + (@NaturalTransformation C D)). +Defined. +Local Notation "C -> D" := (functor_category C D) : category_scope. +Generalizable All Variables. +Definition isisomorphism_components_of `{@IsIsomorphism (C -> D) F G T} x : IsIsomorphism (T x). +Proof. + constructor. + exact (T^-1 x). +Defined. +Hint Immediate isisomorphism_components_of : typeclass_instances. +Goal forall (x3 x9 : PreCategory) (x12 f0 : Functor x9 x3) + (x35 : @Isomorphic (@functor_category x9 x3) f0 x12) + (x37 : object x9) + (H3 : morphism x3 (@object_of x9 x3 f0 x37) + (@object_of x9 x3 f0 x37)) + (x34 : @Isomorphic (@functor_category x9 x3) x12 f0) + (m : morphism x3 (x12 x37) (f0 x37) -> + morphism x3 (f0 x37) (x12 x37) -> + morphism x3 (f0 x37) (f0 x37)), + @paths + (morphism x3 (@object_of x9 x3 f0 x37) (@object_of x9 x3 f0 x37)) + H3 + (m + (@components_of x9 x3 x12 f0 + (@morphism_inverse (@functor_category x9 x3) f0 x12 + (@morphism_isomorphic (@functor_category x9 x3) f0 x12 x35) + (@isisomorphism_isomorphic (@functor_category x9 x3) f0 x12 + x35)) x37) + (@components_of x9 x3 f0 x12 + (@morphism_inverse (@functor_category x9 x3) x12 f0 + (@morphism_isomorphic (@functor_category x9 x3) x12 f0 x34) + (@isisomorphism_isomorphic (@functor_category x9 x3) x12 f0 + x34)) x37)). + Unset Printing All. + intros. + match goal with + | [ |- context[components_of ?T^-1 ?x] ] + => progress let T1 := constr:(T^-1 x) in + let T2 := constr:((T x)^-1) in + change T1 with T2 || fail 1 "too early" + end. + + Undo. + + match goal with + | [ |- context[components_of ?T^-1 ?x] ] + => progress let T1 := constr:(T^-1 x) in + change T1 with ((T x)^-1) || fail 1 "too early 2" + end. + + Undo. + + match goal with + | [ |- context[components_of ?T^-1 ?x] ] + => progress let T2 := constr:((T x)^-1) in + change (T^-1 x) with T2 + end. (* not convertible *) + +(* + + (@components_of x9 x3 x12 f0 + (@morphism_inverse _ _ _ + (@morphism_isomorphic (functor_category x9 x3) f0 x12 x35) _) x37) + +*) \ No newline at end of file diff --git a/test-suite/bugs/closed/3662.v b/test-suite/bugs/closed/3662.v new file mode 100644 index 00000000..bd53389b --- /dev/null +++ b/test-suite/bugs/closed/3662.v @@ -0,0 +1,47 @@ +Set Primitive Projections. +Set Implicit Arguments. +Set Record Elimination Schemes. +Record prod A B := pair { fst : A ; snd : B }. +Definition f : Set -> Type := fun x => x. + +Goal (fst (pair (fun x => x + 1) nat) 0) = 0. +compute. +Undo. +cbv. +Undo. +Opaque fst. +cbn. +Transparent fst. +cbn. +Undo. +simpl. +Undo. +Abort. + +Goal f (fst (pair nat nat)) = nat. +compute. + match goal with + | [ |- fst ?x = nat ] => fail 1 "compute failed" + | [ |- nat = nat ] => idtac + end. + reflexivity. +Defined. + +Goal fst (pair nat nat) = nat. + unfold fst. + match goal with + | [ |- fst ?x = nat ] => fail 1 "compute failed" + | [ |- nat = nat ] => idtac + end. + reflexivity. +Defined. + +Lemma eta A B : forall x : prod A B, x = pair (fst x) (snd x). reflexivity. Qed. + +Goal forall x : prod nat nat, fst x = 0. + intros. unfold fst. + Fail match goal with + | [ |- fst ?x = 0 ] => idtac + end. +Abort. + diff --git a/test-suite/bugs/closed/3664.v b/test-suite/bugs/closed/3664.v new file mode 100644 index 00000000..41de74ff --- /dev/null +++ b/test-suite/bugs/closed/3664.v @@ -0,0 +1,23 @@ +Module NonPrim. + Unset Primitive Projections. + Record c := { d : Set }. + Definition a x := d x. + Goal forall x, a x. + intro x. + Fail progress simpl. (* [progress simpl] fails correctly *) + Fail progress cbn. (* [progress cbn] fails correctly *) + admit. + Defined. +End NonPrim. + +Module Prim. + Set Primitive Projections. + Record c := { d : Set }. + Definition a x := d x. + Goal forall x, a x. + intro x. + Fail progress simpl. (* [progress simpl] fails correctly *) + Fail progress cbn. (* [cbn] succeeds incorrectly, giving [d x] *) + admit. + Defined. +End Prim. \ No newline at end of file diff --git a/test-suite/bugs/closed/3665.v b/test-suite/bugs/closed/3665.v new file mode 100644 index 00000000..f6a13596 --- /dev/null +++ b/test-suite/bugs/closed/3665.v @@ -0,0 +1,33 @@ +(* File reduced by coq-bug-finder from original input, then from 5449 lines to 44 lines *) +(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0 + coqtop version trunk (September 2014) *) +Set Primitive Projections. + +Axiom IsHSet : Type -> Type. +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. + +Module withdefault. +Canonical Structure default_HSet := fun T P => (@BuildhSet T P). +Goal forall (z : hSet) (T0 : Type -> Type), + (forall (A : Type) (P : T0 A -> Type) (aa : T0 A), P aa) -> + forall x0 : setT z, Set. + clear; intros z T H. + Set Debug Unification. + Fail refine (H _ _). (* Timeout! *) +Abort. +End withdefault. + +Module withnondefault. +Variable T0 : Type -> Type. +Variable T0hset: forall A, IsHSet (T0 A). + +Canonical Structure nondefault_HSet := fun A =>(@BuildhSet (T0 A) (T0hset A)). +Canonical Structure default_HSet := fun A P =>(@BuildhSet A P). +Goal forall (z : hSet) (T0 : Type -> Type), + (forall (A : Type) (P : T0 A -> Type) (aa : T0 A), P aa) -> + forall x0 : setT z, Set. + clear; intros z T H. + Set Debug Unification. + Fail refine (H _ _). (* Timeout! *) +Abort. +End withnondefault. diff --git a/test-suite/bugs/closed/3666.v b/test-suite/bugs/closed/3666.v new file mode 100644 index 00000000..a5b0e934 --- /dev/null +++ b/test-suite/bugs/closed/3666.v @@ -0,0 +1,50 @@ +(* File reduced by coq-bug-finder from original input, then from 11542 lines to 325 lines, then from 347 lines to 56 lines, then from 58 lines to 15 lines *) +(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *) + +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). +Inductive V : Type@{U'} := | set {A : Type@{U}} (f : A -> V) : V. +Module NonPrim. + Record hProp := hp { hproptype :> Type ; isp : Set}. + Goal forall (A B : Type) (H_f : A -> V -> hProp) (H_g : B -> V -> hProp) + (C : Type) (h : C -> V) (b : B) (a : A) (c : C), + H_f a (h c) -> H_f a (h c) = H_g b (h c) -> H_g b (h c). + intros A B H_f H_g C h b a c H3 H'. + exact (@transport hProp (fun x => x) _ _ H' H3). + Undo. + Set Debug Unification. + exact (H' # H3). + Defined. +End NonPrim. + +Module Prim. + Set Primitive Projections. + Set Universe Polymorphism. + Record hProp := hp { hproptype :> Type ; isp : Set}. + Goal forall (A B : Type) (H_f : A -> V -> hProp) (H_g : B -> V -> hProp) + (C : Type) (h : C -> V) (b : B) (a : A) (c : C), + H_f a (h c) -> H_f a (h c) = H_g b (h c) -> H_g b (h c). + intros A B H_f H_g C h b a c H3 H'. + exact (@transport hProp (fun x => x) _ _ H' H3). + Undo. + Set Debug Unification. + exact (H' # H3). + (* Toplevel input, characters 7-14: +Error: +In environment +A : Type +B : Type +H_f : A -> V -> hProp +H_g : B -> V -> hProp +C : Type +h : C -> V +b : B +a : A +c : C +H3 : H_f a (h c) +H' : H_f a (h c) = H_g b (h c) +Unable to unify "hproptype (H_f a (h c))" with "?T (H_f a (h c))". + *) + Defined. +End Prim. \ No newline at end of file diff --git a/test-suite/bugs/closed/3667.v b/test-suite/bugs/closed/3667.v new file mode 100644 index 00000000..d2fc4d9b --- /dev/null +++ b/test-suite/bugs/closed/3667.v @@ -0,0 +1,25 @@ + +Set Primitive Projections. +Axiom ap10 : forall {A B} {f g:A->B} (h:f=g) x, f x = g x. +Axiom IsHSet : Type -> Type. +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d) }. +Set Implicit Arguments. +Record NaturalTransformation C D (F G : Functor C D) := + { components_of :> forall c, morphism D (F c) (G c); + commutes : forall s d (m : morphism C s d), components_of s = components_of s }. +Definition set_cat : PreCategory. + exact ((@Build_PreCategory hSet + (fun x y => x -> y))). +Defined. +Goal forall (A : PreCategory) (F : Functor A set_cat) + (a : A) (x : F a) (nt :NaturalTransformation F F), x = x. + intros. + pose (fun c d m => ap10 (commutes nt c d m)). + + diff --git a/test-suite/bugs/closed/3668.v b/test-suite/bugs/closed/3668.v new file mode 100644 index 00000000..547159b9 --- /dev/null +++ b/test-suite/bugs/closed/3668.v @@ -0,0 +1,53 @@ +(* File reduced by coq-bug-finder from original input, then from 6329 lines to 110 lines, then from 115 lines to 88 lines, then from 93 lines to 72 lines *) +(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *) + +Notation "( x ; y )" := (existT _ x y). +Notation "x .1" := (projT1 x) (at level 3, format "x '.1'"). +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }. +Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Notation "A <~> B" := (Equiv A B) (at level 85). +Axiom IsHProp : Type -> Type. +Inductive Bool := true | false. +Definition negb (b : Bool) := if b then false else true. +Hypothesis LEM : forall A : Type, IsHProp A -> A + (A -> False). +Axiom cheat : forall {A},A. +Module NonPrim. + Class Contr (A : Type) := { center : A ; contr : (forall y : A, center = y) }. + Definition Book_6_9 : forall X, X -> X. + Proof. + intro X. + pose proof (@LEM (Contr { f : X <~> X & ~(forall x, f x = x) }) cheat) as contrXEquiv. + destruct contrXEquiv as [[f H]|H]; [ exact f.1 | exact (fun x => x) ]. + Defined. + Lemma Book_6_9_not_id b : Book_6_9 Bool b = negb b. + Proof. + unfold Book_6_9. + destruct (@LEM (Contr { f : Bool <~> Bool & ~(forall x, f x = x) }) _) as [[f H']|H']. + match goal with + | [ |- equiv_fun Bool Bool f.1 b = negb b ] => idtac + | [ |- equiv_fun Bool Bool center.1 b = negb b ] => fail 1 "bad" + end. + all:admit. + Defined. +End NonPrim. +Module Prim. + Set Primitive Projections. + Class Contr (A : Type) := { center : A ; contr : (forall y : A, center = y) }. + Definition Book_6_9 : forall X, X -> X. + Proof. + intro X. + pose proof (@LEM (Contr { f : X <~> X & ~(forall x, f x = x) }) cheat) as contrXEquiv. + destruct contrXEquiv as [[f H]|H]; [ exact (f.1) | exact (fun x => x) ]. + Defined. + Lemma Book_6_9_not_id b : Book_6_9 Bool b = negb b. + Proof. + unfold Book_6_9. + destruct (@LEM (Contr { f : Bool <~> Bool & ~(forall x, f x = x) }) _) as [[f H']|H']. + match goal with + | [ |- equiv_fun Bool Bool f.1 b = negb b ] => idtac + | [ |- equiv_fun Bool Bool center.1 b = negb b ] => fail 1 "bad" + end. (* Tactic failure: bad *) + all:admit. + Defined. +End Prim. \ No newline at end of file diff --git a/test-suite/bugs/closed/3670.v b/test-suite/bugs/closed/3670.v new file mode 100644 index 00000000..c0f03261 --- /dev/null +++ b/test-suite/bugs/closed/3670.v @@ -0,0 +1,23 @@ +Set Universe Polymorphism. +Module Type FOO. + Parameter f : Type -> Type. + Parameter h : forall T, f T. +End FOO. + +Module Type BAR. + Include FOO. +End BAR. + +Module Type BAZ. + Include FOO. +End BAZ. + +Module BAR_FROM_BAZ (baz : BAZ) <: BAR. + + Definition f : Type -> Type. + Proof. exact baz.f. Defined. + + Definition h : forall T, f T. + Admitted. + +Fail End BAR_FROM_BAZ. diff --git a/test-suite/bugs/closed/3672.v b/test-suite/bugs/closed/3672.v new file mode 100644 index 00000000..283be495 --- /dev/null +++ b/test-suite/bugs/closed/3672.v @@ -0,0 +1,27 @@ +Set Primitive Projections. (* No failures without this option. *) + +Record AT := +{ atype :> Type +; coerce : atype -> Type +}. +Coercion coerce : atype >-> Sortclass. + +Record Ar C (A:AT) := { ar : forall (X Y : C), A }. + +Definition t := forall C A a X, coerce _ (ar C A a X X). +Definition t' := forall C A a X, ar C A a X X. + +(* The command has indeed failed with message: +=> Error: The term "ar C A a X X" has type "atype A" which is not a (co-)inductive type. +*) + +Record Ar2 C (A:AT) := +{ ar2 : forall (X Y : C), A +; id2 : forall X, coerce _ (ar2 X X) }. + +Record Ar3 C (A:AT) := +{ ar3 : forall (X Y : C), A +; id3 : forall X, ar3 X X }. +(* The command has indeed failed with message: +=> Anomaly: Bad recursive type. Please report. +*) \ No newline at end of file diff --git a/test-suite/bugs/closed/3675.v b/test-suite/bugs/closed/3675.v new file mode 100644 index 00000000..93227ab8 --- /dev/null +++ b/test-suite/bugs/closed/3675.v @@ -0,0 +1,20 @@ +Set Primitive Projections. +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end. +Notation "p @ q" := (concat p q) (at level 20) : path_scope. +Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : forall x, f (equiv_inv x) = x }. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. +Local Open Scope path_scope. +Local Open Scope equiv_scope. +Generalizable Variables A B C f g. +Lemma isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} +: IsEquiv (compose g f). +Proof. + refine (Build_IsEquiv A C + (compose g f) + (compose f^-1 g^-1) _). + exact (fun c => ap g (@eisretr _ _ f _ (g^-1 c)) @ (@eisretr _ _ g _ c)). diff --git a/test-suite/bugs/closed/3682.v b/test-suite/bugs/closed/3682.v new file mode 100644 index 00000000..b8c5b4d5 --- /dev/null +++ b/test-suite/bugs/closed/3682.v @@ -0,0 +1,5 @@ +Class Foo. +Definition bar `{Foo} (x : Set) := Set. +Instance: Foo. +Definition bar1 := bar nat. +Definition bar2 := bar $(admit)$. diff --git a/test-suite/bugs/closed/3684.v b/test-suite/bugs/closed/3684.v new file mode 100644 index 00000000..94ce4a60 --- /dev/null +++ b/test-suite/bugs/closed/3684.v @@ -0,0 +1,4 @@ +Definition foo : Set. +Proof. + refine ($(abstract admit)$). +Qed. diff --git a/test-suite/bugs/closed/3686.v b/test-suite/bugs/closed/3686.v new file mode 100644 index 00000000..ee6b334b --- /dev/null +++ b/test-suite/bugs/closed/3686.v @@ -0,0 +1,62 @@ +Set Universe Polymorphism. +Set Implicit Arguments. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Bind Scope category_scope with PreCategory. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); + identity_of : forall s m, morphism_of s s m = morphism_of s s m }. +Definition sub_pre_cat (P : PreCategory -> Type) : PreCategory. +Proof. + exact (@Build_PreCategory PreCategory Functor). +Defined. +Definition opposite (C : PreCategory) : PreCategory. +Proof. + exact (@Build_PreCategory C (fun s d => morphism C d s)). +Defined. +Local Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope. +Definition prod (C D : PreCategory) : PreCategory. +Proof. + refine (@Build_PreCategory + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type)). +Defined. +Local Infix "*" := prod : category_scope. +Axiom functor_category : PreCategory -> PreCategory -> PreCategory. +Local Notation "C -> D" := (functor_category C D) : category_scope. +Module Export PointwiseCore. + Definition pointwise + (C C' : PreCategory) + (F : Functor C' C) + (D D' : PreCategory) + (G : Functor D D') + : Functor (C -> D) (C' -> D'). + Proof. + refine (Build_Functor + (C -> D) (C' -> D') + _ + _ + _); + abstract admit. + Defined. +End PointwiseCore. +Axiom Pidentity_of : forall (C D : PreCategory) (F : Functor C C) (G : Functor D D), pointwise F G = pointwise F G. +Local Open Scope category_scope. +Definition functor_uncurried (P : PreCategory -> Type) + (has_functor_categories : forall C D : @sub_pre_cat P, P (C -> D)) +: object (((@sub_pre_cat P)^op * (@sub_pre_cat P)) -> (@sub_pre_cat P)). +Proof. + pose (let object_of := (fun CD => (((fst CD) -> (snd CD)))) + in Build_Functor + ((@sub_pre_cat P)^op * (@sub_pre_cat P)) (@sub_pre_cat P) + object_of + (fun CD C'D' FG => pointwise (fst FG) (snd FG)) + (fun _ _ => Pidentity_of _ _)) || fail "early". + Include PointwiseCore. + pose (let object_of := (fun CD => (((fst CD) -> (snd CD)))) + in Build_Functor + ((@sub_pre_cat P)^op * (@sub_pre_cat P)) (@sub_pre_cat P) + object_of + (fun CD C'D' FG => pointwise (fst FG) (snd FG)) + (fun _ _ => Pidentity_of _ _)). +Abort. diff --git a/test-suite/bugs/closed/3692.v b/test-suite/bugs/closed/3692.v new file mode 100644 index 00000000..72973a8d --- /dev/null +++ b/test-suite/bugs/closed/3692.v @@ -0,0 +1,26 @@ +Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). +Reserved Notation "x = y" (at level 70, no associativity). +Reserved Notation "x * y" (at level 40, left associativity). +Delimit Scope core_scope with core. +Open Scope core_scope. +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Global Set Primitive Projections. +Global Set Implicit Arguments. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'"). +Generalizable Variables X A B f g n. +Axiom path_prod' : forall {A B : Type} {x x' : A} {y y' : B}, (x = x') -> (y = y') -> ((x,y) = (x',y')). +Definition functor_prod {A A' B B' : Type} (f:A->A') (g:B->B') +: A * B -> A' * B'. + exact (fun z => (f (fst z), g (snd z))). +Defined. +Definition isequiv_functor_prod `{IsEquiv A A' f} `{IsEquiv B B' g} +: IsEquiv (functor_prod f g) + := @Build_IsEquiv + _ _ (functor_prod f g) (functor_prod f^-1 g^-1) + (fun z => path_prod' (@eisretr _ _ f _ (fst z)) (@eisretr _ _ g _ (snd z))). diff --git a/test-suite/bugs/closed/3698.v b/test-suite/bugs/closed/3698.v new file mode 100644 index 00000000..3c53d243 --- /dev/null +++ b/test-suite/bugs/closed/3698.v @@ -0,0 +1,25 @@ +(* File reduced by coq-bug-finder from original input, then from 5479 lines to 4682 lines, then from 4214 lines to 86 lines, then from 60 lines to 25 lines *) +(* coqc version trunk (October 2014) compiled on Oct 1 2014 18:13:54 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (68846802a7be637ec805a5e374655a426b5723a5) *) +Set Primitive Projections. +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. +Notation pr1 := projT1. +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. +Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y. +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }. +Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Global Existing Instance equiv_isequiv. +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. +Axiom IsHSet : Type -> Type. +Local Open Scope equiv_scope. +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). +Axiom issig_hSet: (sigT IsHSet) <~> hSet. +Definition isequiv_ap_setT X Y : IsEquiv (@ap _ _ setT X Y). +Proof. + assert (H'' : forall g : X = Y -> (issig_hSet^-1 X).1 = (issig_hSet^-1 Y).1, + g = g -> IsEquiv g) by admit. + Eval compute in (@projT1 Type IsHSet (@equiv_inv _ _ _ (equiv_isequiv _ _ issig_hSet) X)). + Fail apply H''. (* stack overflow *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v new file mode 100644 index 00000000..99b3d79e --- /dev/null +++ b/test-suite/bugs/closed/3699.v @@ -0,0 +1,162 @@ +(* File reduced by coq-bug-finder from original input, then from 9593 lines to 104 lines, then from 187 lines to 103 lines, then from 113 lines to 90 lines *) +(* coqc version trunk (October 2014) compiled on Oct 1 2014 18:13:54 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (68846802a7be637ec805a5e374655a426b5723a5) *) +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Inductive trunc_index := minus_two | trunc_S (_ : trunc_index). +Axiom IsTrunc : trunc_index -> Type -> Type. +Existing Class IsTrunc. +Axiom Contr : Type -> Type. +Inductive Trunc (n : trunc_index) (A :Type) : Type := tr : A -> Trunc n A. +Module NonPrim. + Unset Primitive Projections. + Set Implicit Arguments. + Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. + Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + Unset Implicit Arguments. + Notation "( x ; y )" := (existT _ x y) : fibration_scope. + Open Scope fibration_scope. + Notation pr1 := projT1. + Notation pr2 := projT2. + Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. + Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope. + Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }. + Class IsConnected (n : trunc_index) (A : Type) := isconnected_contr_trunc :> Contr (Trunc n A). + Axiom isconnected_elim : forall {n} {A} `{IsConnected n A} + (C : Type) `{IsTrunc n C} (f : A -> C), + { c:C & forall a:A, f a = c }. + Class IsConnMap (n : trunc_index) {A B : Type} (f : A -> B) + := isconnected_hfiber_conn_map :> forall b:B, IsConnected n (hfiber f b). + Definition conn_map_elim {n : trunc_index} + {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} + (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)} + (d : forall a:A, P (f a)) + : forall b:B, P b. + Proof. + intros b. + refine (pr1 (isconnected_elim _ _)). + 2:exact b. + intro x. + exact (transport P x.2 (d x.1)). + Defined. + + Definition conn_map_elim' {n : trunc_index} + {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} + (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)} + (d : forall a:A, P (f a)) + : forall b:B, P b. + Proof. + intros b. + refine (pr1 (isconnected_elim _ _)). + 2:exact b. + intros [a p]. + exact (transport P p (d a)). + Defined. + + Definition conn_map_comp {n : trunc_index} + {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} + (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)} + (d : forall a:A, P (f a)) + : forall a:A, conn_map_elim f P d (f a) = d a /\ conn_map_elim' f P d (f a) = d a. + Proof. + intros a. + unfold conn_map_elim, conn_map_elim'. + Set Printing Coercions. + set (fibermap := fun a0p : hfiber f (f a) + => let (a0, p) := a0p in transport P p (d a0)). + Set Printing Implicit. + let G := match goal with |- ?G => constr:G end in + first [ match goal with + | [ |- (@isconnected_elim n (@hfiber A B f (f a)) + (@isconnected_hfiber_conn_map n A B f H (f a)) + (P (f a)) (HP (f a)) + (fun x : @hfiber A B f (f a) => + @transport B P (f x.1) (f a) x.2 (d x.1))).1 = + d a /\ _ ] => idtac + end + | fail 1 "projection names should be folded, [let] should generate unfolded projections, goal:" G ]; + first [ match goal with + | [ |- _ /\ (@isconnected_elim n (@hfiber A B f (f a)) + (@isconnected_hfiber_conn_map n A B f H (f a)) + (P (f a)) (HP (f a)) fibermap).1 = d a ] => idtac + end + | fail 1 "destruct should generate unfolded projections, as should [let], goal:" G ]. + admit. + Defined. +End NonPrim. + +Module Prim. + Set Primitive Projections. + Set Implicit Arguments. + Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. + Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + Unset Implicit Arguments. + Notation "( x ; y )" := (existT _ x y) : fibration_scope. + Open Scope fibration_scope. + Notation pr1 := projT1. + Notation pr2 := projT2. + Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. + Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope. + Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }. + Class IsConnected (n : trunc_index) (A : Type) := isconnected_contr_trunc :> Contr (Trunc n A). + Axiom isconnected_elim : forall {n} {A} `{IsConnected n A} + (C : Type) `{IsTrunc n C} (f : A -> C), + { c:C & forall a:A, f a = c }. + Class IsConnMap (n : trunc_index) {A B : Type} (f : A -> B) + := isconnected_hfiber_conn_map :> forall b:B, IsConnected n (hfiber f b). + Definition conn_map_elim {n : trunc_index} + {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} + (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)} + (d : forall a:A, P (f a)) + : forall b:B, P b. + Proof. + intros b. + refine (pr1 (isconnected_elim _ _)). + 2:exact b. + intro x. + exact (transport P x.2 (d x.1)). + Defined. + + Definition conn_map_elim' {n : trunc_index} + {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} + (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)} + (d : forall a:A, P (f a)) + : forall b:B, P b. + Proof. + intros b. + refine (pr1 (isconnected_elim _ _)). + 2:exact b. + intros [a p]. + exact (transport P p (d a)). + Defined. + + Definition conn_map_comp {n : trunc_index} + {A B : Type} (f : A -> B) `{IsConnMap n _ _ f} + (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)} + (d : forall a:A, P (f a)) + : forall a:A, conn_map_elim f P d (f a) = d a /\ conn_map_elim' f P d (f a) = d a. + Proof. + intros a. + unfold conn_map_elim, conn_map_elim'. + Set Printing Coercions. + set (fibermap := fun a0p : hfiber f (f a) + => let (a0, p) := a0p in transport P p (d a0)). + Set Printing Implicit. + let G := match goal with |- ?G => constr:G end in + first [ match goal with + | [ |- (@isconnected_elim n (@hfiber A B f (f a)) + (@isconnected_hfiber_conn_map n A B f H (f a)) + (P (f a)) (HP (f a)) + (fun x : @hfiber A B f (f a) => + @transport B P (f x.1) (f a) x.2 (d x.1))).1 = + d a /\ _ ] => idtac + end + | fail 1 "projection names should be folded, [let] should generate unfolded projections, goal:" G ]; + first [ match goal with + | [ |- _ /\ (@isconnected_elim n (@hfiber A B f (f a)) + (@isconnected_hfiber_conn_map n A B f H (f a)) + (P (f a)) (HP (f a)) fibermap).1 = d a ] => idtac + end + | fail 1 "destruct should generate unfolded projections, as should [let], goal:" G ]. + admit. + Defined. +End Prim. \ No newline at end of file diff --git a/test-suite/bugs/closed/3700.v b/test-suite/bugs/closed/3700.v new file mode 100644 index 00000000..4e226524 --- /dev/null +++ b/test-suite/bugs/closed/3700.v @@ -0,0 +1,84 @@ + +Set Implicit Arguments. +Module NonPrim. + Unset Primitive Projections. + Record prod A B := pair { fst : A ; snd : B }. +End NonPrim. +Module Prim. + Set Primitive Projections. + Record prod A B := pair { fst : A ; snd : B }. +End Prim. +Goal (forall x : NonPrim.prod Set Set, let (a, b) := x in a = a) +/\ (forall x : Prim.prod Set Set, let (a, b) := x in a = a). + Show. (* (forall x : NonPrim.prod Set Set, let (a, _) := x in a = a) /\ + (forall x : Prim.prod Set Set, + let a := Prim.fst x in let b := Prim.snd x in a = a) *) + Set Printing All. + Show. (* and + (forall x : NonPrim.prod Set Set, + match x return Prop with + | NonPrim.pair a _ => @eq Set a a + end) + (forall x : Prim.prod Set Set, + let a := @Prim.fst Set Set x in + let b := @Prim.snd Set Set x in @eq Set a a) *) + Unset Printing All. +Abort. +Goal (forall x : NonPrim.prod Set Set, match x with NonPrim.pair a b => a = a end) +/\ (forall x : Prim.prod Set Set, match x with Prim.pair a b => a = a end). + Show. (* (forall x : NonPrim.prod Set Set, + match x with + | {| NonPrim.fst := a |} => a = a + end) /\ (forall x : Prim.prod Set Set, Prim.fst x = Prim.fst x) *) + (** Wrong: [match] should generate unfolded things *) + Set Printing All. + Show. (* and + (forall x : NonPrim.prod Set Set, + match x return Prop with + | NonPrim.pair a _ => @eq Set a a + end) + (forall x : Prim.prod Set Set, + @eq Set (@Prim.fst Set Set x) (@Prim.fst Set Set x)) *) + Unset Printing All. +Abort. +Goal (forall x : NonPrim.prod Set Set, let (a, b) := x in a = a /\ b = b) +/\ (forall x : Prim.prod Set Set, let (a, b) := x in a = a /\ b = b). + Show. (* (forall x : NonPrim.prod Set Set, let (a, b) := x in a = a /\ b = b) /\ + (forall x : Prim.prod Set Set, + let a := Prim.fst x in let b := Prim.snd x in a = a /\ b = b) *) + (** Understandably different, maybe, but should still be unfolded *) + Set Printing All. + Show. (* and + (forall x : NonPrim.prod Set Set, + match x return Prop with + | NonPrim.pair a b => and (@eq Set a a) (@eq Set b b) + end) + (forall x : Prim.prod Set Set, + let a := @Prim.fst Set Set x in + let b := @Prim.snd Set Set x in and (@eq Set a a) (@eq Set b b)) *) + Unset Printing All. +Abort. +Goal (forall x : NonPrim.prod Set Set, match x with NonPrim.pair a b => a = a /\ b = b end) +/\ (forall x : Prim.prod Set Set, match x with Prim.pair a b => a = a /\ b = b end). + Show. (* (forall x : NonPrim.prod Set Set, + match x with + | {| NonPrim.fst := a; NonPrim.snd := b |} => a = a /\ b = b + end) /\ + (forall x : Prim.prod Set Set, + Prim.fst x = Prim.fst x /\ Prim.snd x = Prim.snd x) *) + Set Printing All. + Show. + + set(foo:=forall x : Prim.prod Set Set, match x return Set with + | Prim.pair fst _ => fst + end). + (* and + (forall x : NonPrim.prod Set Set, + match x return Prop with + | NonPrim.pair a b => and (@eq Set a a) (@eq Set b b) + end) + (forall x : Prim.prod Set Set, + and (@eq Set (@Prim.fst Set Set x) (@Prim.fst Set Set x)) + (@eq Set (@Prim.snd Set Set x) (@Prim.snd Set Set x))) *) + Unset Printing All. +Abort. \ No newline at end of file diff --git a/test-suite/bugs/closed/3709.v b/test-suite/bugs/closed/3709.v new file mode 100644 index 00000000..7f01be7a --- /dev/null +++ b/test-suite/bugs/closed/3709.v @@ -0,0 +1,23 @@ +Module NonPrim. + Unset Primitive Projections. + Record hProp := hp { hproptype :> Type }. + Goal forall (h : (Type -> hProp) -> (Type -> hProp)) k f, + (forall y, h y = y) -> + h (fun b : Type => {| hproptype := f b |}) = k. + Proof. + intros h k f H. + etransitivity. + apply H. + admit. + Defined. +End NonPrim. +Module Prim. + Set Primitive Projections. + Record hProp := hp { hproptype :> Type }. + Goal forall (h : (Type -> hProp) -> (Type -> hProp)) k f, + (forall y, h y = y) -> + h (fun b : Type => {| hproptype := f b |}) = k. + Proof. + intros h k f H. + etransitivity. + apply H. diff --git a/test-suite/bugs/closed/3710.v b/test-suite/bugs/closed/3710.v new file mode 100644 index 00000000..b9e2798d --- /dev/null +++ b/test-suite/bugs/closed/3710.v @@ -0,0 +1,48 @@ +(* File reduced by coq-bug-finder from original input, then from 13477 lines to 1457 lines, then from 1553 lines to 1586 lines, then \ +from 1574 lines to 823 lines, then from 837 lines to 802 lines, then from 793 lines to 657 lines, then from 661 lines to 233 lines, t\ +hen from 142 lines to 65 lines *) +(* coqc version trunk (October 2014) compiled on Oct 8 2014 13:38:17 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (335cf2860bfd9e714d14228d75a52fd2c88db386) *) +Set Universe Polymorphism. +Set Primitive Projections. +Set Implicit Arguments. +Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. +Definition relation (A : Type) := A -> A -> Type. +Class Reflexive {A} (R : relation A) := reflexivity : forall x : A, R x x. +Notation "( x ; y )" := (existT _ x y). +Notation "x .1" := (projT1 x) (at level 3, format "x '.1'"). +Reserved Infix "o" (at level 40, left associativity). +Delimit Scope category_scope with category. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' }. +Delimit Scope functor_scope with functor. +Record Functor (C D : PreCategory) := { object_of :> C -> D }. +Local Open Scope category_scope. +Class Isomorphic {C : PreCategory} (s d : C) := {}. +Axiom composeF : forall C D E (G : Functor D E) (F : Functor C D), Functor C E. +Infix "o" := composeF : functor_scope. +Local Open Scope functor_scope. +Definition sub_pre_cat {P : PreCategory -> Type} : PreCategory. + exact (@Build_PreCategory + { C : PreCategory & P C } + (fun C D => Functor C.1 D.1) + (fun _ _ _ F G => F o G)). +Defined. +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. +Axiom composeT : forall C D (F F' F'' : Functor C D) (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F'), + NaturalTransformation F F''. +Definition functor_category (C D : PreCategory) : PreCategory. + exact (@Build_PreCategory (Functor C D) + (@NaturalTransformation C D) + (@composeT C D)). +Defined. +Local Notation "C -> D" := (functor_category C D) : category_scope. +Definition NaturalIsomorphism (C D : PreCategory) F G : Type := @Isomorphic (C -> D) F G. +Context `{P : PreCategory -> Type}. +Local Notation cat := (@sub_pre_cat P). +Goal forall (s d d' : cat) (m1 : morphism cat d d') (m2 : morphism cat s d), + NaturalIsomorphism (m1 o m2) (m1 o m2)%functor. +Fail exact (fun _ _ _ _ _ => reflexivity _). diff --git a/test-suite/bugs/closed/3723.v b/test-suite/bugs/closed/3723.v new file mode 100644 index 00000000..d0b77c45 --- /dev/null +++ b/test-suite/bugs/closed/3723.v @@ -0,0 +1,6 @@ +(* Bugs #3787 and #3723 on reinitializing camlp5 levels *) + +Definition a := True. +Reserved Notation "-- x" (at level 50, x at level 20). +Reserved Notation "--- x" (at level 20). +Reset a. diff --git a/test-suite/bugs/closed/3782.v b/test-suite/bugs/closed/3782.v new file mode 100644 index 00000000..08d456fc --- /dev/null +++ b/test-suite/bugs/closed/3782.v @@ -0,0 +1,63 @@ +(* File reduced by coq-bug-finder from original input, then from 2674 lines to 136 lines, then from 115 lines to 61 lines *) +(* coqc version trunk (October 2014) compiled on Oct 28 2014 14:33:38 with OCaml 4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,(no branch) (53bfe9cf58a3c40e6eb7120d25c1633a9cea3126) *) +Class IsEquiv {A B : Type} (f : A -> B) := {}. +Record Equiv A B := { equiv_fun : A -> B ; equiv_isequiv : IsEquiv equiv_fun }. +Arguments equiv_fun {A B} _ _. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Set Printing Coercions. +Set Printing Implicit. +Module NonPrim. + Unset Primitive Projections. + Record TruncType (n : nat) := { trunctype_type :> Type }. + Canonical Structure default_TruncType := fun n T => (@Build_TruncType n T). + Goal (forall (s d : TruncType 0) (m : trunctype_type 0 s -> trunctype_type 0 d), + @IsEquiv (trunctype_type 0 s) (trunctype_type 0 d) m -> Type) -> + forall (T T0 : Type) (m : T0 -> T), @IsEquiv T0 T m -> True. + intros isiso_isequiv' mc md e e'. + (pose (@isiso_isequiv' + _ _ + (e + : (Build_TruncType 0 md) -> + (Build_TruncType 0 mc)) + e') as i || fail "too early"); clear i. + pose (@isiso_isequiv' + _ _ _ + e'). + admit. + Defined. +End NonPrim. +Module Prim. + Set Primitive Projections. + Record TruncType (n : nat) := { trunctype_type :> Type }. + Canonical Structure default_TruncType := fun n T => (@Build_TruncType n T). + Goal (forall (s d : TruncType 0) (m : trunctype_type 0 s -> trunctype_type 0 d), + @IsEquiv (trunctype_type 0 s) (trunctype_type 0 d) m -> Type) -> + forall (T T0 : Type) (m : T0 -> T), @IsEquiv T0 T m -> True. + intros isiso_isequiv' mc md e e'. + (pose (@isiso_isequiv' + _ _ + (e + : (Build_TruncType 0 md) -> + (Build_TruncType 0 mc)) + e') as i || fail "too early"); clear i. + Set Printing Existential Instances. + Set Debug Unification. + pose (@isiso_isequiv' + _ _ _ + e'). (* Toplevel input, characters 48-50: +Error: +In environment +isiso_isequiv' : forall (s d : TruncType 0) + (m : trunctype_type 0 s -> trunctype_type 0 d), + @IsEquiv (trunctype_type 0 s) (trunctype_type 0 d) m -> Type +mc : Type +md : Type +e : md -> mc +e' : @IsEquiv md mc e +The term "e'" has type "@IsEquiv md mc e" while it is expected to have type + "@IsEquiv (trunctype_type 0 ?t) (trunctype_type 0 ?t0) ?t1". + *) + admit. + Defined. +End Prim. \ No newline at end of file diff --git a/test-suite/bugs/closed/3788.v b/test-suite/bugs/closed/3788.v new file mode 100644 index 00000000..2c5b9cb0 --- /dev/null +++ b/test-suite/bugs/closed/3788.v @@ -0,0 +1,6 @@ +Set Implicit Arguments. +Global Set Primitive Projections. +Record Functor (C D : Type) := { object_of :> forall _ : C, D }. +Axiom path_functor_uncurried : forall C D (F G : Functor C D) (_ : sigT (fun HO : object_of F = object_of G => Set)), F = G. +Fail Lemma path_functor_uncurried_snd C D F G HO HM +: (@path_functor_uncurried C D F G (existT _ HO HM)) = HM. diff --git a/test-suite/bugs/closed/3792.v b/test-suite/bugs/closed/3792.v new file mode 100644 index 00000000..39057b9c --- /dev/null +++ b/test-suite/bugs/closed/3792.v @@ -0,0 +1,4 @@ +Fail Definition pull_if_dep +: forall {A} (P : bool -> Type) (a : A true) (a' : A false) + (b : bool), + P (if b as b return A b then a else a'). diff --git a/test-suite/bugs/closed/38.v b/test-suite/bugs/closed/38.v new file mode 100644 index 00000000..4fc8d7c9 --- /dev/null +++ b/test-suite/bugs/closed/38.v @@ -0,0 +1,22 @@ +Require Import Setoid. + +Variable A : Set. + +Inductive liste : Set := +| vide : liste +| c : A -> liste -> liste. + +Inductive e : A -> liste -> Prop := +| ec : forall (x : A) (l : liste), e x (c x l) +| ee : forall (x y : A) (l : liste), e x l -> e x (c y l). + +Definition same := fun (l m : liste) => forall (x : A), e x l <-> e x m. + +Definition same_refl (x:liste) : (same x x). + unfold same; split; intros; trivial. +Save. + +Goal forall (x:liste), (same x x). + intro. + apply (same_refl x). +Qed. diff --git a/test-suite/bugs/closed/3804.v b/test-suite/bugs/closed/3804.v new file mode 100644 index 00000000..da9290cb --- /dev/null +++ b/test-suite/bugs/closed/3804.v @@ -0,0 +1,12 @@ +Set Universe Polymorphism. +Module Foo. + Definition T : sigT (fun x => x). + Proof. + exists Set. + abstract exact nat. + Defined. +End Foo. +Module Bar. + Include Foo. +End Bar. +Definition foo := eq_refl : Foo.T = Bar.T. diff --git a/test-suite/bugs/closed/3821.v b/test-suite/bugs/closed/3821.v new file mode 100644 index 00000000..8da4f736 --- /dev/null +++ b/test-suite/bugs/closed/3821.v @@ -0,0 +1,2 @@ +Inductive quotient {A : Type@{i}} {B : Type@{j}} : Type@{max(i, j)} := . + diff --git a/test-suite/bugs/closed/3828.v b/test-suite/bugs/closed/3828.v new file mode 100644 index 00000000..ae11c6c9 --- /dev/null +++ b/test-suite/bugs/closed/3828.v @@ -0,0 +1,2 @@ +Goal 0 = 0. +Fail pose ?Goal. diff --git a/test-suite/bugs/closed/3848.v b/test-suite/bugs/closed/3848.v new file mode 100644 index 00000000..b66aecca --- /dev/null +++ b/test-suite/bugs/closed/3848.v @@ -0,0 +1,21 @@ +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. +Arguments eisretr {A B} f {_} _. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'"). +Generalizable Variables A B f g e n. +Definition functor_forall `{P : A -> Type} `{Q : B -> Type} + (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) +: (forall a:A, P a) -> (forall b:B, Q b). + admit. +Defined. + +Lemma isequiv_functor_forall `{P : A -> Type} `{Q : B -> Type} + `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)} +: (forall b : B, Q b) -> forall a : A, P a. +Proof. + refine (functor_forall + (f^-1) + (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)). +Defined. (* Error: Attempt to save an incomplete proof *) diff --git a/test-suite/bugs/closed/3854.v b/test-suite/bugs/closed/3854.v new file mode 100644 index 00000000..f8329cdd --- /dev/null +++ b/test-suite/bugs/closed/3854.v @@ -0,0 +1,21 @@ +Definition relation (A : Type) := A -> A -> Type. +Class Reflexive {A} (R : relation A) := reflexivity : forall x : A, R x x. +Axiom IsHProp : Type -> Type. +Existing Class IsHProp. +Inductive Empty : Set := . +Notation "~ x" := (x -> Empty) : type_scope. +Record hProp := BuildhProp { type :> Type ; trunc : IsHProp type }. +Arguments BuildhProp _ {_}. +Canonical Structure default_hProp := fun T P => (@BuildhProp T P). +Generalizable Variables A B f g e n. +Axiom trunc_forall : forall `{P : A -> Type}, IsHProp (forall a, P a). +Existing Instance trunc_forall. +Inductive V : Type := | set {A : Type} (f : A -> V) : V. +Axiom mem : V -> V -> hProp. +Axiom mem_induction +: forall (C : V -> hProp), (forall v, (forall x, mem x v -> C x) -> C v) -> forall v, C v. +Definition irreflexive_mem : forall x, (fun x y => ~ mem x y) x x. +Proof. + pose (fun x => BuildhProp (~ mem x x)). + refine (mem_induction (fun x => BuildhProp (~ mem x x)) _); simpl in *. + admit. diff --git a/test-suite/bugs/closed/3892.v b/test-suite/bugs/closed/3892.v new file mode 100644 index 00000000..833722ba --- /dev/null +++ b/test-suite/bugs/closed/3892.v @@ -0,0 +1,8 @@ +(* Check that notation variables do not capture names hidden behind + another notation. *) +Notation "A <-> B" := ((A -> B) * (B -> A))%type : type_scope. +Notation compose := (fun g f x => g (f x)). +Notation "g 'o' f" := (compose g f) (at level 40, left associativity). +Definition iff_compose {A B C : Type} (g : B <-> C) (f : A <-> B) : A <-> C := + (fst g o fst f , snd f o snd g). +(* Used to fail with: This expression should be a name. *) diff --git a/test-suite/bugs/closed/3895.v b/test-suite/bugs/closed/3895.v new file mode 100644 index 00000000..8659ca2c --- /dev/null +++ b/test-suite/bugs/closed/3895.v @@ -0,0 +1,22 @@ +Notation pr1 := (@projT1 _ _). +Notation compose := (fun g' f' x => g' (f' x)). +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : +function_scope. +Open Scope function_scope. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p +with eq_refl => eq_refl end. +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) := forall x:A, +f x = g x. +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : +type_scope. +Theorem Univalence_implies_FunextNondep (A B : Type) +: forall f g : A -> B, f == g -> f = g. +Proof. + intros f g p. + pose (d := fun x : A => existT (fun xy => fst xy = snd xy) (f x, f x) +(eq_refl (f x))). + pose (e := fun x : A => existT (fun xy => fst xy = snd xy) (f x, g x) (p x)). + change f with ((snd o pr1) o d). + change g with ((snd o pr1) o e). + apply (ap (fun g => snd o pr1 o g)). +(* Used to raise a not Found due to a "typo" in solve_evar_evar *) diff --git a/test-suite/bugs/closed/3896.v b/test-suite/bugs/closed/3896.v new file mode 100644 index 00000000..b433922a --- /dev/null +++ b/test-suite/bugs/closed/3896.v @@ -0,0 +1,4 @@ +Goal True. +pose proof 0 as n. +Fail apply pair in n. +(* Used to be an anomaly for a while *) diff --git a/test-suite/bugs/closed/3899.v b/test-suite/bugs/closed/3899.v new file mode 100644 index 00000000..e83166aa --- /dev/null +++ b/test-suite/bugs/closed/3899.v @@ -0,0 +1,11 @@ +Set Primitive Projections. +Record unit : Set := tt {}. +Fail Check fun x : unit => eq_refl : tt = x. +Fail Check fun x : unit => eq_refl : x = tt. +Fail Check fun x y : unit => (eq_refl : x = tt) : x = y. +Fail Check fun x y : unit => eq_refl : x = y. + +Record ok : Set := tt' { a : unit }. + +Record nonprim : Prop := { undef : unit }. +Record prim : Prop := { def : True }. \ No newline at end of file diff --git a/test-suite/bugs/closed/545.v b/test-suite/bugs/closed/545.v new file mode 100644 index 00000000..926af7dd --- /dev/null +++ b/test-suite/bugs/closed/545.v @@ -0,0 +1,5 @@ +Require Export Reals. + +Parameter toto : nat -> nat -> nat. + +Notation " e # f " := (toto e f) (at level 30, f at level 0). diff --git a/test-suite/bugs/closed/808_2411.v b/test-suite/bugs/closed/808_2411.v new file mode 100644 index 00000000..1c13e745 --- /dev/null +++ b/test-suite/bugs/closed/808_2411.v @@ -0,0 +1,27 @@ +Section test. +Variable n:nat. +Lemma foo: 0 <= n. +Proof. +(* declaring an Axiom during a proof makes it immediatly + usable, juste as a full Definition. *) +Axiom bar : n = 1. +rewrite bar. +now apply le_S. +Qed. + +Lemma foo' : 0 <= n. +Proof. +(* Declaring an Hypothesis during a proof is ok, + but this hypothesis won't be usable by the current proof(s), + only by later ones. *) +Hypothesis bar' : n = 1. +Fail rewrite bar'. +Abort. + +Lemma foo'' : 0 <= n. +Proof. +rewrite bar'. +now apply le_S. +Qed. + +End test. \ No newline at end of file diff --git a/test-suite/bugs/closed/846.v b/test-suite/bugs/closed/846.v new file mode 100644 index 00000000..ee5ec1fa --- /dev/null +++ b/test-suite/bugs/closed/846.v @@ -0,0 +1,213 @@ +Set Implicit Arguments. + +Open Scope type_scope. + +Inductive One : Set := inOne: One. + +Definition maybe: forall A B:Set,(A -> B) -> One + A -> One + B. +Proof. + intros A B f c. + case c. + left; assumption. + right; apply f; assumption. +Defined. + +Definition id (A:Set)(a:A):=a. + +Definition LamF (X: Set -> Set)(A:Set) :Set := + A + (X A)*(X A) + X(One + A). + +Definition LamF' (X: Set -> Set)(A:Set) :Set := + LamF X A. + +Require Import List. +Require Import Bool. + +Definition index := list bool. + +Inductive L (A:Set) : index -> Set := + initL: A -> L A nil + | pluslL: forall l:index, One -> L A (false::l) + | plusrL: forall l:index, L A l -> L A (false::l) + | varL: forall l:index, L A l -> L A (true::l) + | appL: forall l:index, L A (true::l) -> L A (true::l) -> L A (true::l) + | absL: forall l:index, L A (true::false::l) -> L A (true::l). + +Scheme L_rec_simp := Minimality for L Sort Set. + +Definition Lam' (A:Set) := L A (true::nil). + +Definition aczelapp: forall (l1 l2: index)(A:Set), L (L A l2) l1 -> L A + (l1++l2). +Proof. + intros l1 l2 A. + generalize l1. + clear l1. + (* Check (fun i:index => L A (i++l2)). *) + apply (L_rec_simp (A:=L A l2) (fun i:index => L A (i++l2))). + trivial. + intros l o. + simpl app. + apply pluslL; assumption. + intros l _ t. + simpl app. + apply plusrL; assumption. + intros l _ t. + simpl app. + apply varL; assumption. + intros l _ t1 _ t2. + simpl app in *|-*. + Check 0. + apply appL; [exact t1| exact t2]. + intros l _ t. + simpl app in *|-*. + Check 0. + apply absL; assumption. +Defined. + +Definition monL: forall (l:index)(A:Set)(B:Set), (A->B) -> L A l -> L B l. +Proof. + intros l A B f. + intro t. + elim t. + intro a. + exact (initL (f a)). + intros i u. + exact (pluslL _ _ u). + intros i _ r. + exact (plusrL r). + intros i _ r. + exact (varL r). + intros i _ r1 _ r2. + exact (appL r1 r2). + intros i _ r. + exact (absL r). +Defined. + +Definition lam': forall (A B:Set), (A -> B) -> Lam' A -> Lam' B. +Proof. + intros A B f t. + unfold Lam' in *|-*. + Check 0. + exact (monL f t). +Defined. + +Definition inLam': forall A:Set, LamF' Lam' A -> Lam' A. +Proof. + intros A [[a|[t1 t2]]|r]. + unfold Lam'. + exact (varL (initL a)). + exact (appL t1 t2). + unfold Lam' in * |- *. + Check 0. + apply absL. + change (L A ((true::nil) ++ (false::nil))). + apply aczelapp. + (* Check (fun x:One + A => (match (maybe (fun a:A => initL a) x) with + | inl u => pluslL _ _ u + | inr t' => plusrL t' end)). *) + exact (monL (fun x:One + A => + (match (maybe (fun a:A => initL a) x) with + | inl u => pluslL _ _ u + | inr t' => plusrL t' end)) r). +Defined. + +Section minimal. + +Definition sub1 (F G: Set -> Set):= forall A:Set, F A->G A. +Hypothesis G: Set -> Set. +Hypothesis step: sub1 (LamF' G) G. + +Fixpoint L'(A:Set)(i:index){struct i} : Set := + match i with + nil => A + | false::l => One + L' A l + | true::l => G (L' A l) + end. + +Definition LinL': forall (A:Set)(i:index), L A i -> L' A i. +Proof. + intros A i t. + elim t. + intro a. + unfold L'. + assumption. + intros l u. + left; assumption. + intros l _ r. + right; assumption. + intros l _ r. + apply (step (A:=L' A l)). + exact (inl _ (inl _ r)). + intros l _ r1 _ r2. + apply (step (A:=L' A l)). + (* unfold L' in * |- *. + Check 0. *) + exact (inl _ (inr _ (pair r1 r2))). + intros l _ r. + apply (step (A:=L' A l)). + exact (inr _ r). +Defined. + +Definition L'inG: forall A: Set, L' A (true::nil) -> G A. +Proof. + intros A t. + unfold L' in t. + assumption. +Defined. + +Definition Itbasic: sub1 Lam' G. +Proof. + intros A t. + apply L'inG. + unfold Lam' in t. + exact (LinL' t). +Defined. + +End minimal. + +Definition recid := Itbasic inLam'. + +Definition L'Lam'inL: forall (i:index)(A:Set), L' Lam' A i -> L A i. +Proof. + intros i A t. + induction i. + unfold L' in t. + apply initL. + assumption. + induction a. + simpl L' in t. + apply (aczelapp (l1:=true::nil) (l2:=i)). + exact (lam' IHi t). + simpl L' in t. + induction t. + exact (pluslL _ _ a). + exact (plusrL (IHi b)). +Defined. + + +Lemma recidgen: forall(A:Set)(i:index)(t:L A i), L'Lam'inL i A (LinL' inLam' t) + = t. +Proof. + intros A i t. + induction t. + trivial. + trivial. + simpl. + rewrite IHt. + trivial. + simpl L'Lam'inL. + rewrite IHt. + trivial. + simpl L'Lam'inL. + simpl L'Lam'inL in IHt1. + unfold lam' in IHt1. + simpl L'Lam'inL in IHt2. + unfold lam' in IHt2. + + (* going on. This fails for the original solution. *) + rewrite IHt1. + rewrite IHt2. + trivial. +Abort. (* one goal still left *) + diff --git a/test-suite/bugs/closed/931.v b/test-suite/bugs/closed/931.v new file mode 100644 index 00000000..e86b3be6 --- /dev/null +++ b/test-suite/bugs/closed/931.v @@ -0,0 +1,7 @@ +Parameter P : forall n : nat, n=n -> Prop. + +Goal Prop. + refine (P _ _). + 2:instantiate (1:=0). + trivial. +Qed. diff --git a/test-suite/bugs/closed/HoTT_coq_001.v b/test-suite/bugs/closed/HoTT_coq_001.v new file mode 100644 index 00000000..bf1d024b --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_001.v @@ -0,0 +1,5 @@ +Record Foo : Set := + { + A' : nat; + A : Prop := (A' = 0) + }. (* Anomaly: Uncaught exception Reduction.NotConvertible. Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_002.v b/test-suite/bugs/closed/HoTT_coq_002.v new file mode 100644 index 00000000..ba69f6b1 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_002.v @@ -0,0 +1,33 @@ +Set Implicit Arguments. + +Generalizable All Variables. + +Parameter SpecializedCategory : Type -> Type. +Parameter Object : forall obj, SpecializedCategory obj -> Type. + +Section SpecializedFunctor. + (* Variable objC : Type. *) + Context `(C : SpecializedCategory objC). + + Polymorphic Record SpecializedFunctor := { + ObjectOf' : objC -> Type; + ObjectC : Object C + }. +End SpecializedFunctor. + +Section FunctorInterface. + Variable objC : Type. + Variable C : SpecializedCategory objC. + Variable F : SpecializedFunctor C. + + Set Printing All. + Set Printing Universes. + Check @ObjectOf' objC C F. (* Toplevel input, characters 24-25: +Error: +In environment +objC : Type (* Top.515 *) +C : SpecializedCategory objC +F : @SpecializedFunctor (* Top.516 *) objC C +The term "F" has type "@SpecializedFunctor (* Top.516 *) objC C" + while it is expected to have type + "@SpecializedFunctor (* Top.519 Top.520 *) objC C". *) diff --git a/test-suite/bugs/closed/HoTT_coq_006.v b/test-suite/bugs/closed/HoTT_coq_006.v new file mode 100644 index 00000000..c7943b84 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_006.v @@ -0,0 +1,99 @@ +Module FirstIssue. + Set Implicit Arguments. + + Record Cat (obj : Type) := {}. + + Record Functor objC (C : Cat objC) objD (D : Cat objD) := + { + ObjectOf' : objC -> objD + }. + + Definition TypeCat : Cat Type. constructor. Defined. + Definition PropCat : Cat Prop. constructor. Defined. + + Definition FunctorFrom_Type2Prop objC (C : Cat objC) (F : Functor TypeCat C) : Functor PropCat C. + Set Printing All. + Set Printing Universes. + Check F. (* F : @Functor Type (* Top.1201 *) TypeCat objC C *) + exact (Build_Functor PropCat C (ObjectOf' F)). + Show Proof. (* (fun (objC : Type (* Top.1194 *)) (C : Cat objC) + (F : @Functor Prop TypeCat objC C) => + @Build_Functor Prop PropCat objC C + (@ObjectOf' Prop TypeCat objC C F)) *) + Defined. + (* Error: Illegal application (Type Error): +The term "Functor" of type + "forall (objC : Type (* Top.1194 *)) (_ : Cat objC) + (objD : Type (* Top.1194 *)) (_ : Cat objD), + Type (* Top.1194 *)" +cannot be applied to the terms + "Prop" : "Type (* (Set)+1 *)" + "TypeCat" : "Cat Type (* Top.1201 *)" + "objC" : "Type (* Top.1194 *)" + "C" : "Cat objC" +The 2nd term has type "Cat Type (* Top.1201 *)" +which should be coercible to "Cat Prop". *) +End FirstIssue. + +Module SecondIssue. + Set Implicit Arguments. + + Set Printing Universes. + + Polymorphic Record Cat (obj : Type) := + { + Object :> _ := obj; + Morphism' : obj -> obj -> Type + }. + + Polymorphic Record Functor objC (C : Cat objC) objD (D : Cat objD) := + { + ObjectOf' : objC -> objD; + MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d) + }. + + Definition SetCat : Cat Set := @Build_Cat Set (fun x y => x -> y). + Definition PropCat : Cat Prop := @Build_Cat Prop (fun x y => x -> y). + + Set Printing All. + + Definition FunctorFrom_Set2Prop objC (C : Cat objC) (F : Functor SetCat C) : Functor PropCat C. + exact (Build_Functor PropCat C + (ObjectOf' F) + (MorphismOf' F) + ). + Defined. (* Error: Illegal application (Type Error): +The term "Build_Functor (* Top.748 Prop Top.808 Top.809 *)" of type + "forall (objC : Type (* Top.748 *)) (C : Cat (* Top.748 Prop *) objC) + (objD : Type (* Top.808 *)) (D : Cat (* Top.808 Top.809 *) objD) + (ObjectOf' : forall _ : objC, objD) + (_ : forall (s d : objC) (_ : @Morphism' (* Top.748 Prop *) objC C s d), + @Morphism' (* Top.808 Top.809 *) objD D (ObjectOf' s) (ObjectOf' d)), + @Functor (* Top.748 Prop Top.808 Top.809 *) objC C objD D" +cannot be applied to the terms + "Prop" : "Type (* (Set)+1 *)" + "PropCat" : "Cat (* Top.748 Prop *) Prop" + "objC" : "Type (* Top.808 *)" + "C" : "Cat (* Top.808 Top.809 *) objC" + "fun x : Prop => + @ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F x" + : "forall _ : Prop, objC" + "@MorphismOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F" + : "forall (s d : Set) (_ : @Morphism' (* Top.744 Prop *) Set SetCat s d), + @Morphism' (* Top.808 Top.809 *) objC C + (@ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F s) + (@ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F d)" +The 6th term has type + "forall (s d : Set) (_ : @Morphism' (* Top.744 Prop *) Set SetCat s d), + @Morphism' (* Top.808 Top.809 *) objC C + (@ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F s) + (@ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F d)" +which should be coercible to + "forall (s d : Prop) (_ : @Morphism' (* Top.748 Prop *) Prop PropCat s d), + @Morphism' (* Top.808 Top.809 *) objC C + ((fun x : Prop => + @ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F x) s) + ((fun x : Prop => + @ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F x) d)". + *) +End SecondIssue. diff --git a/test-suite/bugs/closed/HoTT_coq_007.v b/test-suite/bugs/closed/HoTT_coq_007.v new file mode 100644 index 00000000..8592c729 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_007.v @@ -0,0 +1,112 @@ +Module Comment1. + Set Implicit Arguments. + + Polymorphic Record Category (obj : Type) := + { + Morphism : obj -> obj -> Type; + Identity : forall o, Morphism o o + }. + + Polymorphic Record Functor objC (C :Category objC) objD (D : Category objD) := + { + ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d); + FIdentityOf : forall o, MorphismOf _ _ (C.(Identity) o) = D.(Identity) (ObjectOf o) + }. + + Create HintDb functor discriminated. + + Hint Rewrite @FIdentityOf : functor. + + Polymorphic Definition ComposeFunctors objC C objD D objE E (G : @Functor objD D objE E) (F : @Functor objC C objD D) : Functor C E. + refine {| ObjectOf := (fun c => G (F c)); + MorphismOf := (fun _ _ m => G.(MorphismOf) _ _ (F.(MorphismOf) _ _ m)) + |}; + intros; autorewrite with functor; reflexivity. + Defined. + + Definition Cat0 : Category@{i j} Empty_set. + refine {| + Morphism := fun s d : Empty_set => s = d; + Identity := fun o : Empty_set => eq_refl + |}; + admit. + Defined. + + Set Printing All. + Set Printing Universes. + + Lemma foo objC (C : @Category objC) (C0 : Category (Functor Cat0 C)) (x : Functor Cat0 Cat0) + : forall (y : Functor C0 Cat0) z, (ComposeFunctors y z = x). + intro. intro. + unfold ComposeFunctors. + Abort. +End Comment1. + +Module Comment2. + Set Implicit Arguments. + + Polymorphic Record Category (obj : Type) := + { + Morphism : obj -> obj -> Type; + + Identity : forall o, Morphism o o; + Compose : forall s d d2, Morphism d d2 -> Morphism s d -> Morphism s d2; + + LeftIdentity : forall a b (f : Morphism a b), Compose (Identity b) f = f + }. + + Polymorphic Record Functor objC (C : Category objC) objD (D : Category objD) := + { + ObjectOf : objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. + + Create HintDb morphism discriminated. + + Polymorphic Hint Resolve @LeftIdentity : morphism. + + Polymorphic Definition ProductCategory objC (C : Category objC) objD (D : Category objD) : @Category (objC * objD)%type. + refine {| + Morphism := (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type); + Identity := (fun o => (Identity _ (fst o), Identity _ (snd o))); + Compose := (fun (s d d2 : (objC * objD)%type) m2 m1 => (C.(Compose) _ _ _ (fst m2) (fst m1), D.(Compose) _ _ _ (snd m2) (snd m1))) + |}; + intros; apply injective_projections; simpl; auto with morphism. (* Replacing [auto with morphism] with [apply @LeftIdentity] removes the error *) + Defined. + + Polymorphic Definition Cat0 : Category Empty_set. + refine {| + Morphism := fun s d : Empty_set => s = d; + Identity := fun o : Empty_set => eq_refl; + Compose := fun s d d2 m0 m1 => eq_trans m1 m0 + |}; + admit. + Defined. + + Set Printing All. + Set Printing Universes. + Polymorphic Definition ProductLaw0Functor (objC : Type) (C : Category objC) : Functor (ProductCategory C Cat0) Cat0. + refine (Build_Functor (ProductCategory C Cat0) Cat0 _ _). (* Toplevel input, characters 15-71: +Error: Refiner was given an argument + "prod (* Top.2289 Top.2289 *) objC Empty_set" of type +"Type (* Top.2289 *)" instead of "Set". *) + Abort. + Polymorphic Definition ProductLaw0Functor (objC : Type) (C : Category objC) : Functor (ProductCategory C Cat0) Cat0. + econstructor. (* Toplevel input, characters 0-12: +Error: No applicable tactic. + *) + Abort. +End Comment2. + + +Module Comment3. + Polymorphic Lemma foo {obj : Type} : 1 = 1. + trivial. + Qed. + + Polymorphic Hint Resolve foo. (* success *) + Polymorphic Hint Rewrite @foo. (* Success *) + Polymorphic Hint Resolve @foo. (* Error: @foo is a term and cannot be made a polymorphic hint, only global references can be polymorphic hints. *) + Fail Polymorphic Hint Rewrite foo. (* Error: Cannot infer the implicit parameter obj of foo. *) +End Comment3. diff --git a/test-suite/bugs/closed/HoTT_coq_010.v b/test-suite/bugs/closed/HoTT_coq_010.v new file mode 100644 index 00000000..42b1244f --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_010.v @@ -0,0 +1,3 @@ +SearchAbout and. +(* Anomaly: Mismatched instance and context when building universe substitution. +Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_012.v b/test-suite/bugs/closed/HoTT_coq_012.v new file mode 100644 index 00000000..a3c697f8 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_012.v @@ -0,0 +1,4 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) + +Definition UU := Type. +Inductive toto (B : UU) : UU := c (x : B). diff --git a/test-suite/bugs/closed/HoTT_coq_013.v b/test-suite/bugs/closed/HoTT_coq_013.v new file mode 100644 index 00000000..13962d5b --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_013.v @@ -0,0 +1,24 @@ +Set Implicit Arguments. +Generalizable All Variables. + +Polymorphic Variant Category (obj : Type) :=. + + Polymorphic Variant Functor objC (C : Category objC) objD (D : Category objD) :=. + + Polymorphic Definition ComposeFunctors objC C objD D objE E (G : @Functor objD D objE E) (F : @Functor objC C objD D) : Functor C E. +Admitted. + +Polymorphic Definition ProductCategory objC (C : Category objC) objD (D : Category objD) : @Category (objC * objD)%type. +Admitted. + +Polymorphic Definition Cat0 : Category Empty_set. +Admitted. + +Set Printing Universes. + +Lemma ProductLaw0 objC (C : Category objC) (F : Functor (ProductCategory C Cat0) Cat0) (G : Functor Cat0 (ProductCategory C Cat0)) x y : + ComposeFunctors F G = x /\ + ComposeFunctors G F = y. +Proof. + split. (* Error: Refiner was given an argument "(objC * 0)%type" of type "Type" instead of "Set". *) +Abort. diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v new file mode 100644 index 00000000..63548a64 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_014.v @@ -0,0 +1,200 @@ +Set Implicit Arguments. +Generalizable All Variables. +Set Universe Polymorphism. + +Polymorphic Record SpecializedCategory (obj : Type) := Build_SpecializedCategory' { + Object :> _ := obj; + Morphism' : obj -> obj -> Type; + + Identity' : forall o, Morphism' o o; + Compose' : forall s d d', Morphism' d d' -> Morphism' s d -> Morphism' s d' +}. + +Polymorphic Definition Morphism obj (C : @SpecializedCategory obj) : forall s d : C, _ := Eval cbv beta delta [Morphism'] in C.(Morphism'). + +(* eh, I'm not terribly happy. meh. *) +Polymorphic Definition SmallSpecializedCategory (obj : Set) (*mor : obj -> obj -> Set*) := SpecializedCategory@{Set Set} obj. +Polymorphic Identity Coercion SmallSpecializedCategory_LocallySmallSpecializedCategory_Id : SmallSpecializedCategory >-> SpecializedCategory. + +Polymorphic Record Category := { + CObject : Type; + + UnderlyingCategory :> @SpecializedCategory CObject +}. + +Polymorphic Definition GeneralizeCategory `(C : @SpecializedCategory obj) : Category. + refine {| CObject := C.(Object) |}; auto. +Defined. + +Polymorphic Coercion GeneralizeCategory : SpecializedCategory >-> Category. + + + +Section SpecializedFunctor. + Set Universe Polymorphism. + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Unset Universe Polymorphism. + + Polymorphic Record SpecializedFunctor := { + ObjectOf' : objC -> objD; + MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d); + FCompositionOf' : forall s d d' (m1 : C.(Morphism') s d) (m2: C.(Morphism') d d'), + MorphismOf' _ _ (C.(Compose') _ _ _ m2 m1) = D.(Compose') _ _ _ (MorphismOf' _ _ m2) (MorphismOf' _ _ m1); + FIdentityOf' : forall o, MorphismOf' _ _ (C.(Identity') o) = D.(Identity') (ObjectOf' o) + }. +End SpecializedFunctor. + +Global Polymorphic Coercion ObjectOf' : SpecializedFunctor >-> Funclass. +Set Universe Polymorphism. +Section Functor. + Variable C D : Category. + + Polymorphic Definition Functor := SpecializedFunctor C D. +End Functor. +Unset Universe Polymorphism. + +Polymorphic Identity Coercion Functor_SpecializedFunctor_Id : Functor >-> SpecializedFunctor. +Polymorphic Definition GeneralizeFunctor objC C objD D (F : @SpecializedFunctor objC C objD D) : Functor C D := F. +Polymorphic Coercion GeneralizeFunctor : SpecializedFunctor >-> Functor. + +Arguments SpecializedFunctor {objC} C {objD} D. + + +Polymorphic Record SmallCategory := { + SObject : Set; + + SUnderlyingCategory :> @SmallSpecializedCategory SObject +}. + +Polymorphic Definition GeneralizeSmallCategory `(C : @SmallSpecializedCategory obj) : SmallCategory. + refine {| SObject := obj |}; destruct C; econstructor; eassumption. +Defined. + +Polymorphic Coercion GeneralizeSmallCategory : SmallSpecializedCategory >-> SmallCategory. + +Bind Scope category_scope with SmallCategory. + + +Polymorphic Definition TypeCat : @SpecializedCategory Type := (@Build_SpecializedCategory' Type + (fun s d => s -> d) + (fun _ => (fun x => x)) + (fun _ _ _ f g => (fun x => f (g x)))). +(*Unset Universe Polymorphism.*) +Polymorphic Definition FunctorCategory objC (C : @SpecializedCategory objC) objD (D : @SpecializedCategory objD) : + @SpecializedCategory (SpecializedFunctor C D). +Admitted. + +Polymorphic Definition DiscreteCategory (O : Type) : @SpecializedCategory O. +Admitted. + +Polymorphic Definition ComputableCategory (I : Type) (Index2Object : I -> Type) (Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)) : + @SpecializedCategory I. +Admitted. + +Polymorphic Definition is_unique (A : Type) (x : A) := forall x' : A, x' = x. + +Polymorphic Definition InitialObject obj {C : SpecializedCategory obj} (o : C) := + forall o', { m : C.(Morphism) o o' | is_unique m }. + +Polymorphic Definition SmallCat := ComputableCategory _ SUnderlyingCategory. + +Lemma InitialCategory_Initial : InitialObject (C := SmallCat) (DiscreteCategory Empty_set : SmallSpecializedCategory _). + admit. +Qed. + +Set Universe Polymorphism. +Section GraphObj. + Context `(C : @SpecializedCategory objC). + + Inductive GraphIndex := GraphIndexSource | GraphIndexTarget. + + Definition GraphIndex_Morphism (a b : GraphIndex) : Set := + match (a, b) with + | (GraphIndexSource, GraphIndexSource) => unit + | (GraphIndexTarget, GraphIndexTarget) => unit + | (GraphIndexTarget, GraphIndexSource) => Empty_set + | (GraphIndexSource, GraphIndexTarget) => GraphIndex + end. + + Global Arguments GraphIndex_Morphism a b /. + + Definition GraphIndex_Compose s d d' (m1 : GraphIndex_Morphism d d') (m2 : GraphIndex_Morphism s d) : + GraphIndex_Morphism s d'. + Admitted. + + Definition GraphIndexingCategory : @SpecializedCategory GraphIndex. + refine {| + Morphism' := GraphIndex_Morphism; + Identity' := (fun x => match x with GraphIndexSource => tt | GraphIndexTarget => tt end); + Compose' := GraphIndex_Compose + |}; + admit. + Defined. + + Definition UnderlyingGraph_ObjectOf x := + match x with + | GraphIndexSource => { sd : objC * objC & C.(Morphism) (fst sd) (snd sd) } + | GraphIndexTarget => objC + end. + + Global Arguments UnderlyingGraph_ObjectOf x /. + + Definition UnderlyingGraph_MorphismOf s d (m : Morphism GraphIndexingCategory s d) : + UnderlyingGraph_ObjectOf s -> UnderlyingGraph_ObjectOf d. + Admitted. + + Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat. + Proof. + match goal with + | [ |- SpecializedFunctor ?C ?D ] => + refine (Build_SpecializedFunctor C D + UnderlyingGraph_ObjectOf + UnderlyingGraph_MorphismOf + _ + _ + ) + end; + admit. + Defined. +End GraphObj. + +Set Printing Universes. +Set Printing All. + +Print Coercions. + +Section test. + +Fail Polymorphic Definition UnderlyingGraphFunctor_MorphismOf' (C D : SmallCategory) (F : SpecializedFunctor C D) : + Morphism (FunctorCategory TypeCat GraphIndexingCategory) + (@UnderlyingGraph (SObject C) + (SmallSpecializedCategory_LocallySmallSpecializedCategory_Id (SUnderlyingCategory C))) + (UnderlyingGraph D). + (* Toplevel input, characters 216-249: +Error: +In environment +C : SmallCategory (* Top.594 *) +D : SmallCategory (* Top.595 *) +F : +@SpecializedFunctor (* Top.25 Set Top.25 Set *) (SObject (* Top.25 *) C) + (SUnderlyingCategory (* Top.25 *) C) (SObject (* Top.25 *) D) + (SUnderlyingCategory (* Top.25 *) D) +The term + "SUnderlyingCategory (* Top.25 *) C + :SpecializedCategory (* Top.25 Set *) (SObject (* Top.25 *) C)" has type + "SpecializedCategory (* Top.618 Top.619 *) (SObject (* Top.25 *) C)" +while it is expected to have type + "SpecializedCategory (* Top.224 Top.225 *) (SObject (* Top.617 *) C)" +(Universe inconsistency: Cannot enforce Set = Top.225)). + *) +Fail Admitted. + +Fail Polymorphic Definition UnderlyingGraphFunctor_MorphismOf (C D : SmallCategory) (F : SpecializedFunctor C D) : + Morphism (FunctorCategory TypeCat GraphIndexingCategory) (UnderlyingGraph C) (UnderlyingGraph D). (* Anomaly: apply_coercion. Please report.*) +Fail Admitted. + +Polymorphic Definition UnderlyingGraphFunctor_MorphismOf (C D : SmallCategory) (F : SpecializedFunctor C D) : + Morphism (FunctorCategory GraphIndexingCategory TypeCat) (UnderlyingGraph C) (UnderlyingGraph D). (* Anomaly: apply_coercion. Please report.*) +Proof. +Admitted. \ No newline at end of file diff --git a/test-suite/bugs/closed/HoTT_coq_016.v b/test-suite/bugs/closed/HoTT_coq_016.v new file mode 100644 index 00000000..4f12cf1a --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_016.v @@ -0,0 +1,15 @@ +Set Printing Universes. +Local Close Scope nat_scope. +Check (fun ab : Prop * Prop => (fst ab : Prop) * (snd ab : Prop)). +(* fun ab : Prop * Prop => +(fst (* Top.5817 Top.5818 *) ab:Prop) * (snd (* Top.5817 Top.5818 *) ab:Prop) + : Prop * Prop -> Prop *) +Check (fun ab : Prop * Prop => (fst ab : Prop) * (snd ab : Prop) : Prop). +(* Toplevel input, characters 51-84: +Error: In environment +ab : Prop * Prop +The term + "(fst (* Top.5833 Top.5834 *) ab:Prop) * + (snd (* Top.5833 Top.5834 *) ab:Prop)" has type + "Type (* max(Top.5829, Top.5830) *)" while it is expected to have type + "Prop". *) diff --git a/test-suite/bugs/closed/HoTT_coq_020.v b/test-suite/bugs/closed/HoTT_coq_020.v new file mode 100644 index 00000000..b16c1df2 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_020.v @@ -0,0 +1,95 @@ +Set Implicit Arguments. + +Generalizable All Variables. + +Set Asymmetric Patterns. + +Polymorphic Record Category (obj : Type) := + Build_Category { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Polymorphic Record Functor objC (C : Category objC) objD (D : Category objD) := + { ObjectOf :> objC -> objD }. + +Polymorphic Record NaturalTransformation objC C objD D (F G : Functor (objC := objC) C (objD := objD) D) := + { ComponentsOf' :> forall c, D.(Morphism) (F.(ObjectOf) c) (G.(ObjectOf) c); + Commutes' : forall s d (m : C.(Morphism) s d), ComponentsOf' s = ComponentsOf' s }. + +Ltac present_obj from to := + match goal with + | [ _ : appcontext[from ?obj ?C] |- _ ] => progress change (from obj C) with (to obj C) in * + | [ |- appcontext[from ?obj ?C] ] => progress change (from obj C) with (to obj C) in * + end. + +Section NaturalTransformationComposition. + Set Universe Polymorphism. + Context `(C : @Category objC). + Context `(D : @Category objD). + Context `(E : @Category objE). + Variables F F' F'' : Functor C D. + Unset Universe Polymorphism. + + Polymorphic Definition NTComposeT (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F') : + NaturalTransformation F F''. + exists (fun c => Compose _ _ _ _ (T' c) (T c)). + repeat progress present_obj @Morphism @Morphism. (* removing this line makes the error go away *) + intros. (* removing this line makes the error go away *) + admit. + Defined. +End NaturalTransformationComposition. + + +Polymorphic Definition FunctorCategory objC (C : Category objC) objD (D : Category objD) : + @Category (Functor C D) + := @Build_Category (Functor C D) + (NaturalTransformation (C := C) (D := D)) + (NTComposeT (C := C) (D := D)). + +Polymorphic Definition Cat0 : Category Empty_set + := @Build_Category Empty_set + (@eq _) + (fun x => match x return _ with end). + +Polymorphic Definition FunctorFrom0 objC (C : Category objC) : Functor Cat0 C + := Build_Functor Cat0 C (fun x => match x with end). + +Section Law0. + Variable objC : Type. + Variable C : Category objC. + + Set Printing All. + Set Printing Universes. + Set Printing Existential Instances. + + Polymorphic Definition ExponentialLaw0Functor_Inverse_ObjectOf' : Object (@FunctorCategory Empty_set Cat0 objC C). + (* In environment +objC : Type (* Top.154 *) +C : Category (* Top.155 Top.154 *) objC +The term "objC" has type "Type (* Top.154 *)" +while it is expected to have type "Type (* Top.184 *)" +(Universe inconsistency: Cannot enforce Top.154 <= Set)). *) + Admitted. + + Polymorphic Definition ExponentialLaw0Functor_Inverse_ObjectOf : Object (FunctorCategory Cat0 C). + hnf. + refine (@FunctorFrom0 _ _). + + (* Toplevel input, characters 23-40: +Error: +In environment +objC : Type (* Top.61069 *) +C : Category (* Top.61069 Top.61071 *) objC +The term + "@FunctorFrom0 (* Top.61077 Top.61078 *) ?69 (* [objC, C] *) + ?70 (* [objC, C] *)" has type + "@Functor (* Set Prop Top.61077 Top.61078 *) Empty_set Cat0 + ?69 (* [objC, C] *) ?70 (* [objC, C] *)" + while it is expected to have type + "@Functor (* Set Prop Set Prop *) Empty_set Cat0 objC C". +*) + Defined. +End Law0. diff --git a/test-suite/bugs/closed/HoTT_coq_023.v b/test-suite/bugs/closed/HoTT_coq_023.v new file mode 100644 index 00000000..b52140de --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_023.v @@ -0,0 +1,12 @@ +Set Universe Polymorphism. + +Record Type_Over (X : Type) +:= { Domain :> Type; + proj : Domain -> X }. + +Definition Self_Over (X : Type) + := {| Domain := X; proj := (fun x => x) |}. + +Canonical Structure Self_Over. (* fails with Anomaly: Mismatched instance and context when building universe substitution. Please report. for polymorphic structures *) +(* if monomorphic, Warning: No global reference exists for projection + valuefun x : _UNBOUND_REL_1 => x in instance Self_Over of proj, ignoring it. *) diff --git a/test-suite/bugs/closed/HoTT_coq_025.v b/test-suite/bugs/closed/HoTT_coq_025.v new file mode 100644 index 00000000..b81b454d --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_025.v @@ -0,0 +1,29 @@ +Module monomorphic. + Class Inhabited (A : Type) : Prop := populate { _ : A }. + Arguments populate {_} _. + + Instance prod_inhabited {A B : Type} (iA : Inhabited A) + (iB : Inhabited B) : Inhabited (A * B) := + match iA, iB with + | populate x, populate y => populate (x,y) + end. + (* Error: In environment +A : Type +B : Type +iA : Inhabited A +iB : Inhabited B +The term "(A * B)%type" has type "Type" while it is expected to have type +"Prop". *) +End monomorphic. + +Module polymorphic. + Set Universe Polymorphism. + Class Inhabited (A : Type) : Prop := populate { _ : A }. + Arguments populate {_} _. + + Instance prod_inhabited {A B : Type} (iA : Inhabited A) + (iB : Inhabited B) : Inhabited (A * B) := + match iA, iB with + | populate x, populate y => populate (x,y) + end. +End polymorphic. diff --git a/test-suite/bugs/closed/HoTT_coq_027.v b/test-suite/bugs/closed/HoTT_coq_027.v new file mode 100644 index 00000000..27834cc4 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_027.v @@ -0,0 +1,94 @@ +Set Implicit Arguments. +Generalizable All Variables. +Set Asymmetric Patterns. +Set Universe Polymorphism. + +Record Category (obj : Type) := { Morphism : obj -> obj -> Type }. + +Record Functor `(C : Category objC) `(D : Category objD) := + { ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) }. + +Definition TypeCat : @Category Type := @Build_Category Type (fun s d => s -> d). +Definition SetCat : @Category Set := @Build_Category Set (fun s d => s -> d). + +Definition FunctorToSet `(C : @Category objC) := Functor C SetCat. +Definition FunctorToType `(C : @Category objC) := Functor C TypeCat. + +(* Removing the following line, as well as the [Definition] and [Identity Coercion] immediately following it, makes the file go through *) +Identity Coercion FunctorToType_Id : FunctorToType >-> Functor. + +Set Printing Universes. +Definition FunctorTo_Set2Type `(C : @Category objC) (F : FunctorToSet C) +: FunctorToType C. + refine (@Build_Functor _ C _ TypeCat + (fun x => F.(ObjectOf) x) + (fun s d m => F.(MorphismOf) _ _ m)). +(* ??? Toplevel input, characters 8-148: +Error: +In environment +objC : Type{Top.100} +C : Category@{Top.100 Top.101} objC +F : FunctorToSet@{Top.100 Top.101 Top.99} C +The term + "{| + ObjectOf := fun x : objC => F x; + MorphismOf := fun (s d : objC) (m : Morphism@{Top.100 Top.101} C s d) => + MorphismOf@{Top.100 Top.101 Top.99 Set} F s d m |}" has type + "Functor@{Top.104 Top.105 Top.106 Top.107} C TypeCat@{Top.108 Top.109 + Top.110}" while it is expected to have type + "FunctorToType@{Top.100 Top.101 Top.102 Top.103} C" +(Universe inconsistency: Cannot enforce Set = Top.103)). + *) +Defined. (* Toplevel input, characters 0-8: +Error: +The term + "fun (objC : Type) (C : Category objC) (F : FunctorToSet C) => + {| + ObjectOf := fun x : objC => F x; + MorphismOf := fun (s d : objC) (m : Morphism C s d) => MorphismOf F s d m |}" +has type + "forall (objC : Type) (C : Category objC), + FunctorToSet C -> Functor C TypeCat" while it is expected to have type + "forall (objC : Type) (C : Category objC), FunctorToSet C -> FunctorToType C". + *) + +Coercion FunctorTo_Set2Type : FunctorToSet >-> FunctorToType. + +Record GrothendieckPair `(C : @Category objC) (F : Functor C TypeCat) := + { GrothendieckC : objC; + GrothendieckX : F GrothendieckC }. + +Record SetGrothendieckPair `(C : @Category objC) (F' : Functor C SetCat) := + { SetGrothendieckC : objC; + SetGrothendieckX : F' SetGrothendieckC }. + +Section SetGrothendieckCoercion. + Context `(C : @Category objC). + Variable F : Functor C SetCat. + Let F' := (F : FunctorToSet _) : FunctorToType _. (* The command has indeed failed with message: +=> Anomaly: apply_coercion_args: mismatch between arguments and coercion. +Please report. *) + + Set Printing Universes. + Definition SetGrothendieck2Grothendieck (G : SetGrothendieckPair F) : GrothendieckPair F' + := {| GrothendieckC := G.(SetGrothendieckC); GrothendieckX := G.(SetGrothendieckX) : F' _ |}. + (* Toplevel input, characters 0-187: +Error: Illegal application: +The term "ObjectOf (* Top.8375 Top.8376 Top.8379 Set *)" of type + "forall (objC : Type (* Top.8375 *)) + (C : Category (* Top.8375 Top.8376 *) objC) (objD : Type (* Top.8379 *)) + (D : Category (* Top.8379 Set *) objD), + Functor (* Top.8375 Top.8376 Top.8379 Set *) C D -> objC -> objD" +cannot be applied to the terms + "objC" : "Type (* Top.8375 *)" + "C" : "Category (* Top.8375 Top.8376 *) objC" + "Type (* Set *)" : "Type (* Set+1 *)" + "TypeCat (* Top.8379 Set *)" : "Category (* Top.8379 Set *) Set" + "F'" : "FunctorToType (* Top.8375 Top.8376 Top.8379 Set *) C" + "SetGrothendieckC (* Top.8375 Top.8376 Top.8379 *) G" : "objC" +The 5th term has type "FunctorToType (* Top.8375 Top.8376 Top.8379 Set *) C" +which should be coercible to + "Functor (* Top.8375 Top.8376 Top.8379 Set *) C TypeCat (* Top.8379 Set *)". + *) +End SetGrothendieckCoercion. diff --git a/test-suite/bugs/closed/HoTT_coq_028.v b/test-suite/bugs/closed/HoTT_coq_028.v new file mode 100644 index 00000000..b0324140 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_028.v @@ -0,0 +1,14 @@ +Goal forall (O obj : Type) (f : O -> obj) (x : O) (e : x = x) + (T : obj -> obj -> Type) (m : forall x0 : obj, T x0 x0), + match eq_sym e in (_ = y) return (T (f y) (f x)) with + | eq_refl => m (f x) + end = m (f x). +intros. +try case e. +(* Toplevel input, characters 19-25: +Error: Cannot instantiate metavariable P of type +"forall a : O, x = a -> Prop" with abstraction +"fun (x : O) (e : x = x) => + match eq_sym e in (_ = y) return (T (f y) (f x)) with + | eq_refl => m (f x) + end = m (f x)" of incompatible type "forall x : O, x = x -> Prop". *) diff --git a/test-suite/bugs/closed/HoTT_coq_029.v b/test-suite/bugs/closed/HoTT_coq_029.v new file mode 100644 index 00000000..4fd54b56 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_029.v @@ -0,0 +1,335 @@ +Module FirstComment. + Set Implicit Arguments. + Generalizable All Variables. + Set Asymmetric Patterns. + Set Universe Polymorphism. + + Reserved Notation "x # y" (at level 40, left associativity). + Reserved Notation "x #m y" (at level 40, left associativity). + + Delimit Scope object_scope with object. + Delimit Scope morphism_scope with morphism. + Delimit Scope category_scope with category. + + Record Category (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Identity : forall x, Morphism x x; + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + + Bind Scope object_scope with Object. + Bind Scope morphism_scope with Morphism. + + Arguments Object {obj%type} C%category / : rename. + Arguments Morphism {obj%type} !C%category s d : rename. (* , simpl nomatch. *) + Arguments Identity {obj%type} [!C%category] x%object : rename. + Arguments Compose {obj%type} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + + Bind Scope category_scope with Category. + + Record Functor + `(C : @Category objC) + `(D : @Category objD) + := { + ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. + + Record NaturalTransformation + `(C : @Category objC) + `(D : @Category objD) + (F G : Functor C D) + := { + ComponentsOf :> forall c, D.(Morphism) (F c) (G c) + }. + + Definition ProductCategory + `(C : @Category objC) + `(D : @Category objD) + : @Category (objC * objD)%type. + refine (@Build_Category _ + (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type) + (fun o => (Identity (fst o), Identity (snd o))) + (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1)))). + + Defined. + + Infix "*" := ProductCategory : category_scope. + + Record IsomorphismOf `{C : @Category objC} {s d} (m : C.(Morphism) s d) := + { + IsomorphismOf_Morphism :> C.(Morphism) s d := m; + Inverse : C.(Morphism) d s + }. + + Record NaturalIsomorphism + `(C : @Category objC) + `(D : @Category objD) + (F G : Functor C D) + := { + NaturalIsomorphism_Transformation :> NaturalTransformation F G; + NaturalIsomorphism_Isomorphism : forall x : objC, IsomorphismOf (NaturalIsomorphism_Transformation x) + }. + + Section PreMonoidalCategory. + Context `(C : @Category objC). + + Variable TensorProduct : Functor (C * C) C. + + Let src {C : @Category objC} {s d} (_ : Morphism C s d) := s. + Let dst {C : @Category objC} {s d} (_ : Morphism C s d) := d. + + Local Notation "A # B" := (TensorProduct (A, B)). + Local Notation "A #m B" := (TensorProduct.(MorphismOf) ((@src _ _ _ A, @src _ _ _ B)) ((@dst _ _ _ A, @dst _ _ _ B)) (A, B)%morphism). + + Let TriMonoidalProductL_ObjectOf (abc : C * C * C) : C := + (fst (fst abc) # snd (fst abc)) # snd abc. + + Let TriMonoidalProductR_ObjectOf (abc : C * C * C) : C := + fst (fst abc) # (snd (fst abc) # snd abc). + + Let TriMonoidalProductL_MorphismOf (s d : C * C * C) (m : Morphism (C * C * C) s d) : + Morphism C (TriMonoidalProductL_ObjectOf s) (TriMonoidalProductL_ObjectOf d). + Admitted. + + Let TriMonoidalProductR_MorphismOf (s d : C * C * C) (m : Morphism (C * C * C) s d) : + Morphism C (TriMonoidalProductR_ObjectOf s) (TriMonoidalProductR_ObjectOf d). + Admitted. + + Definition TriMonoidalProductL : Functor (C * C * C) C. + refine (Build_Functor (C * C * C) C + TriMonoidalProductL_ObjectOf + TriMonoidalProductL_MorphismOf). + Defined. + + Definition TriMonoidalProductR : Functor (C * C * C) C. + refine (Build_Functor (C * C * C) C + TriMonoidalProductR_ObjectOf + TriMonoidalProductR_MorphismOf). + Defined. + + Variable Associator : NaturalIsomorphism TriMonoidalProductL TriMonoidalProductR. + + Section AssociatorCoherenceCondition. + Variables a b c d : C. + + (* going from top-left *) + Let AssociatorCoherenceConditionT0 : Morphism C (((a # b) # c) # d) ((a # (b # c)) # d) + := Associator (a, b, c) #m Identity (C := C) d. + Let AssociatorCoherenceConditionT1 : Morphism C ((a # (b # c)) # d) (a # ((b # c) # d)) + := Associator (a, b # c, d). + Let AssociatorCoherenceConditionT2 : Morphism C (a # ((b # c) # d)) (a # (b # (c # d))) + := Identity (C := C) a #m Associator (b, c, d). + Let AssociatorCoherenceConditionB0 : Morphism C (((a # b) # c) # d) ((a # b) # (c # d)) + := Associator (a # b, c, d). + Let AssociatorCoherenceConditionB1 : Morphism C ((a # b) # (c # d)) (a # (b # (c # d))) + := Associator (a, b, c # d). + + Definition AssociatorCoherenceCondition' := + Compose AssociatorCoherenceConditionT2 (Compose AssociatorCoherenceConditionT1 AssociatorCoherenceConditionT0) + = Compose AssociatorCoherenceConditionB1 AssociatorCoherenceConditionB0. + End AssociatorCoherenceCondition. + + Definition AssociatorCoherenceCondition := Eval unfold AssociatorCoherenceCondition' in + forall a b c d : C, AssociatorCoherenceCondition' a b c d. + End PreMonoidalCategory. + + Section MonoidalCategory. + Variable objC : Type. + + Let AssociatorCoherenceCondition' := Eval unfold AssociatorCoherenceCondition in @AssociatorCoherenceCondition. + + Record MonoidalCategory := + { + MonoidalUnderlyingCategory :> @Category objC; + TensorProduct : Functor (MonoidalUnderlyingCategory * MonoidalUnderlyingCategory) MonoidalUnderlyingCategory; + IdentityObject : objC; + Associator : NaturalIsomorphism (TriMonoidalProductL TensorProduct) (TriMonoidalProductR TensorProduct); + AssociatorCoherent : AssociatorCoherenceCondition' Associator + }. + End MonoidalCategory. + + Section EnrichedCategory. + Context `(M : @MonoidalCategory objM). + Let x : M := IdentityObject M. + (* Anomaly: apply_coercion_args: mismatch between arguments and coercion. Please report. *) + End EnrichedCategory. +End FirstComment. + +Module SecondComment. + Set Implicit Arguments. + Set Universe Polymorphism. + Generalizable All Variables. + + Record prod (A B : Type) := pair { fst : A; snd : B }. + Arguments fst {A B} _. + Arguments snd {A B} _. + Infix "*" := prod : type_scope. + Notation " ( x , y ) " := (@pair _ _ x y). + Record Category (obj : Type) := + Build_Category { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Identity : forall x, Morphism x x; + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + + Arguments Identity {obj%type} [!C] x : rename. + Arguments Compose {obj%type} [!C s d d'] m1 m2 : rename. + + Record > Category' := + { + LSObject : Type; + + LSUnderlyingCategory :> @Category LSObject + }. + + Section Functor. + Context `(C : @Category objC). + Context `(D : @Category objD). + + + Record Functor := + { + ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. + End Functor. + + Arguments MorphismOf {objC%type} [C] {objD%type} [D] F [s d] m : rename, simpl nomatch. + + Section FunctorComposition. + Context `(C : @Category objC). + Context `(D : @Category objD). + Context `(E : @Category objE). + + Definition ComposeFunctors (G : Functor D E) (F : Functor C D) : Functor C E. + Admitted. + End FunctorComposition. + + Section IdentityFunctor. + Context `(C : @Category objC). + + + Definition IdentityFunctor : Functor C C. + refine {| ObjectOf := (fun x => x); + MorphismOf := (fun _ _ x => x) + |}. + Defined. + End IdentityFunctor. + + Section ProductCategory. + Context `(C : @Category objC). + Context `(D : @Category objD). + + Definition ProductCategory : @Category (objC * objD)%type. + refine (@Build_Category _ + (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type) + (fun o => (Identity (fst o), Identity (snd o))) + (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1)))). + Defined. + End ProductCategory. + + Definition OppositeCategory `(C : @Category objC) : Category objC := + @Build_Category objC + (fun s d => Morphism C d s) + (Identity (C := C)) + (fun _ _ _ m1 m2 => Compose m2 m1). + + Parameter FunctorCategory : forall `(C : @Category objC) `(D : @Category objD), @Category (Functor C D). + + Parameter TerminalCategory : Category unit. + + Section ComputableCategory. + Variable I : Type. + Variable Index2Object : I -> Type. + Variable Index2Cat : forall i : I, @Category (@Index2Object i). + + Local Coercion Index2Cat : I >-> Category. + + Definition ComputableCategory : @Category I. + refine (@Build_Category _ + (fun C D : I => Functor C D) + (fun o : I => IdentityFunctor o) + (fun C D E : I => ComposeFunctors (C := C) (D := D) (E := E))). + Defined. + End ComputableCategory. + + Section SmallCat. + Definition LocallySmallCat := ComputableCategory _ LSUnderlyingCategory. + End SmallCat. + + Section CommaCategory. + Context `(A : @Category objA). + Context `(B : @Category objB). + Context `(C : @Category objC). + Variable S : Functor A C. + Variable T : Functor B C. + + Record CommaCategory_Object := { CommaCategory_Object_Member :> { ab : objA * objB & C.(Morphism) (S (fst ab)) (T (snd ab)) } }. + + Let SortPolymorphic_Helper (A T : Type) (Build_T : A -> T) := A. + + Definition CommaCategory_ObjectT := Eval hnf in SortPolymorphic_Helper Build_CommaCategory_Object. + Definition Build_CommaCategory_Object' (mem : CommaCategory_ObjectT) := Build_CommaCategory_Object mem. + Global Coercion Build_CommaCategory_Object' : CommaCategory_ObjectT >-> CommaCategory_Object. + + Definition CommaCategory : @Category CommaCategory_Object. + Admitted. + End CommaCategory. + + Definition SliceCategory_Functor `(C : @Category objC) (a : C) : Functor TerminalCategory C + := {| ObjectOf := (fun _ => a); + MorphismOf := (fun _ _ _ => Identity a) + |}. + + Definition SliceCategoryOver + : forall (objC : Type) (C : Category objC) (a : C), + Category + (CommaCategory_Object (IdentityFunctor C) + (SliceCategory_Functor C a)). + admit. + Defined. + + Section CommaCategoryProjectionFunctor. + Context `(A : Category objA). + Context `(B : Category objB). + Context `(C : Category objC). + + Variable S : (OppositeCategory (FunctorCategory A C)). + Variable T : (FunctorCategory B C). + + Definition CommaCategoryProjection : Functor (CommaCategory S T) (ProductCategory A B). + Admitted. + + Definition CommaCategoryProjectionFunctor_ObjectOf + : @SliceCategoryOver _ LocallySmallCat (ProductCategory A B) + := + existT _ + ((CommaCategory S T) : Category', tt) + (CommaCategoryProjection) : + CommaCategory_ObjectT (IdentityFunctor _) + (SliceCategory_Functor LocallySmallCat + (ProductCategory A B)). + (* Anomaly: apply_coercion_args: mismatch between arguments and coercion. Please report. *) + (* Toplevel input, characters 110-142: +Error: +In environment +objA : Type +A : Category objA +objB : Type +B : Category objB +objC : Type +C : Category objC +S : OppositeCategory (FunctorCategory A C) +T : FunctorCategory B C +The term "ProductCategory A B:Category (objA * objB)" has type + "Category (objA * objB)" while it is expected to have type + "Object LocallySmallCat". + *) + End CommaCategoryProjectionFunctor. +End SecondComment. diff --git a/test-suite/bugs/closed/HoTT_coq_030.v b/test-suite/bugs/closed/HoTT_coq_030.v new file mode 100644 index 00000000..fa5ee25c --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_030.v @@ -0,0 +1,241 @@ +Set Implicit Arguments. +Generalizable All Variables. +Set Asymmetric Patterns. +Set Universe Polymorphism. + +Delimit Scope object_scope with object. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope functor_scope with functor. + +Local Open Scope category_scope. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Bind Scope category_scope with SpecializedCategory. +Bind Scope object_scope with Object. +Bind Scope morphism_scope with Morphism. + +Arguments Object {obj%type} C%category / : rename. +Arguments Morphism {obj%type} !C%category s d : rename. (* , simpl nomatch. *) +Arguments Compose {obj%type} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + +Record Category := { + CObject : Type; + + UnderlyingCategory :> @SpecializedCategory CObject +}. + +Definition GeneralizeCategory `(C : @SpecializedCategory obj) : Category. + refine {| CObject := C.(Object) |}; auto. (* Changing this [auto] to [assumption] removes the universe inconsistency. *) +Defined. + +Coercion GeneralizeCategory : SpecializedCategory >-> Category. + +Record SpecializedFunctor + `(C : @SpecializedCategory objC) + `(D : @SpecializedCategory objD) + := { + ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. + +Section Functor. + Context (C D : Category). + + Definition Functor := SpecializedFunctor C D. +End Functor. + +Bind Scope functor_scope with SpecializedFunctor. +Bind Scope functor_scope with Functor. + +Arguments SpecializedFunctor {objC} C {objD} D. +Arguments Functor C D. +Arguments ObjectOf {objC%type C%category objD%type D%category} F%functor c%object : rename, simpl nomatch. +Arguments MorphismOf {objC%type} [C%category] {objD%type} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. + +Section FunctorComposition. + Context `(B : @SpecializedCategory objB). + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Context `(E : @SpecializedCategory objE). + + Definition ComposeFunctors (G : SpecializedFunctor D E) (F : SpecializedFunctor C D) : SpecializedFunctor C E + := Build_SpecializedFunctor C E + (fun c => G (F c)) + (fun _ _ m => G.(MorphismOf) (F.(MorphismOf) m)). +End FunctorComposition. + +Record SpecializedNaturalTransformation + `{C : @SpecializedCategory objC} + `{D : @SpecializedCategory objD} + (F G : SpecializedFunctor C D) + := { + ComponentsOf :> forall c, D.(Morphism) (F c) (G c) + }. + +Definition ProductCategory + `(C : @SpecializedCategory objC) + `(D : @SpecializedCategory objD) +: @SpecializedCategory (objC * objD)%type + := @Build_SpecializedCategory _ + (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type) + (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1))). + +Infix "*" := ProductCategory : category_scope. + +Section ProductCategoryFunctors. + Context `{C : @SpecializedCategory objC}. + Context `{D : @SpecializedCategory objD}. + + Definition fst_Functor : SpecializedFunctor (C * D) C + := Build_SpecializedFunctor (C * D) C + (@fst _ _) + (fun _ _ => @fst _ _). + + Definition snd_Functor : SpecializedFunctor (C * D) D + := Build_SpecializedFunctor (C * D) D + (@snd _ _) + (fun _ _ => @snd _ _). +End ProductCategoryFunctors. + + +Definition OppositeCategory `(C : @SpecializedCategory objC) : @SpecializedCategory objC := + @Build_SpecializedCategory objC + (fun s d => Morphism C d s) + (fun _ _ _ m1 m2 => Compose m2 m1). + +Section OppositeFunctor. + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Variable F : SpecializedFunctor C D. + Let COp := OppositeCategory C. + Let DOp := OppositeCategory D. + + Definition OppositeFunctor : SpecializedFunctor COp DOp + := Build_SpecializedFunctor COp DOp + (fun c : COp => F c : DOp) + (fun (s d : COp) (m : C.(Morphism) d s) => MorphismOf F (s := d) (d := s) m). +End OppositeFunctor. + +Section FunctorProduct. + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Context `(D' : @SpecializedCategory objD'). + + Definition FunctorProduct (F : Functor C D) (F' : Functor C D') : SpecializedFunctor C (D * D'). + match goal with + | [ |- SpecializedFunctor ?C0 ?D0 ] => + refine (Build_SpecializedFunctor + C0 D0 + (fun c => (F c, F' c)) + (fun s d m => (MorphismOf F m, MorphismOf F' m))) + end. + Defined. +End FunctorProduct. + +Section FunctorProduct'. + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Context `(C' : @SpecializedCategory objC'). + Context `(D' : @SpecializedCategory objD'). + Variable F : Functor C D. + Variable F' : Functor C' D'. + + Definition FunctorProduct' : SpecializedFunctor (C * C') (D * D') + := FunctorProduct (ComposeFunctors F fst_Functor) (ComposeFunctors F' snd_Functor). +End FunctorProduct'. + +(** XXX TODO(jgross): Change this to [FunctorProduct]. *) +Infix "*" := FunctorProduct' : functor_scope. + +Definition TypeCat : @SpecializedCategory Type := + (@Build_SpecializedCategory Type + (fun s d => s -> d) + (fun _ _ _ f g => (fun x => f (g x)))). + +Section HomFunctor. + Context `(C : @SpecializedCategory objC). + Let COp := OppositeCategory C. + + Definition CovariantHomFunctor (A : COp) : SpecializedFunctor C TypeCat + := Build_SpecializedFunctor C TypeCat + (fun X : C => C.(Morphism) A X : TypeCat) + (fun X Y f => (fun g : C.(Morphism) A X => Compose f g)). + + Definition hom_functor_object_of (c'c : COp * C) := C.(Morphism) (fst c'c) (snd c'c) : TypeCat. + + Definition hom_functor_morphism_of (s's : (COp * C)%type) (d'd : (COp * C)%type) (hf : (COp * C).(Morphism) s's d'd) : + TypeCat.(Morphism) (hom_functor_object_of s's) (hom_functor_object_of d'd). + unfold hom_functor_object_of in *. + destruct s's as [ s' s ], d'd as [ d' d ]. + destruct hf as [ h f ]. + intro g. + exact (Compose f (Compose g h)). + Defined. + + Definition HomFunctor : SpecializedFunctor (COp * C) TypeCat + := Build_SpecializedFunctor (COp * C) TypeCat + (fun c'c : COp * C => C.(Morphism) (fst c'c) (snd c'c) : TypeCat) + (fun X Y (hf : (COp * C).(Morphism) X Y) => hom_functor_morphism_of hf). +End HomFunctor. + +Section FullFaithful. + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Variable F : SpecializedFunctor C D. + Let COp := OppositeCategory C. + Let DOp := OppositeCategory D. + Let FOp := OppositeFunctor F. + + Definition InducedHomNaturalTransformation : + SpecializedNaturalTransformation (HomFunctor C) (ComposeFunctors (HomFunctor D) (FOp * F)) + := (Build_SpecializedNaturalTransformation (HomFunctor C) (ComposeFunctors (HomFunctor D) (FOp * F)) + (fun sd : (COp * C) => + MorphismOf F (s := _) (d := _))). +End FullFaithful. + +Definition FunctorCategory + `(C : @SpecializedCategory objC) + `(D : @SpecializedCategory objD) +: @SpecializedCategory (SpecializedFunctor C D). + refine (@Build_SpecializedCategory _ + (SpecializedNaturalTransformation (C := C) (D := D)) + _); + admit. +Defined. + +Notation "C ^ D" := (FunctorCategory D C) : category_scope. + +Section Yoneda. + Context `(C : @SpecializedCategory objC). + Let COp := OppositeCategory C. + + Section Yoneda. + Let Yoneda_NT s d (f : COp.(Morphism) s d) : SpecializedNaturalTransformation (CovariantHomFunctor C s) (CovariantHomFunctor C d) + := Build_SpecializedNaturalTransformation + (CovariantHomFunctor C s) + (CovariantHomFunctor C d) + (fun c : C => (fun m : C.(Morphism) _ _ => Compose m f)). + + Definition Yoneda : SpecializedFunctor COp (TypeCat ^ C) + := Build_SpecializedFunctor COp (TypeCat ^ C) + (fun c : COp => CovariantHomFunctor C c : TypeCat ^ C) + (fun s d (f : Morphism COp s d) => Yoneda_NT s d f). + End Yoneda. +End Yoneda. + +Section FullyFaithful. + Context `(C : @SpecializedCategory objC). + + Set Printing Universes. + Check InducedHomNaturalTransformation (Yoneda C). + (* Error: Universe inconsistency (cannot enforce Top.865 = Top.851 because +Top.851 < Top.869 <= Top.864 <= Top.865). *) +End FullyFaithful. diff --git a/test-suite/bugs/closed/HoTT_coq_032.v b/test-suite/bugs/closed/HoTT_coq_032.v new file mode 100644 index 00000000..3f5d7b02 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_032.v @@ -0,0 +1,22 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-xml") -*- *) +Set Implicit Arguments. +Generalizable All Variables. +Set Asymmetric Patterns. +Set Universe Polymorphism. + +Delimit Scope object_scope with object. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope functor_scope with functor. + +Local Open Scope category_scope. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. +(* Anomaly: Mismatched instance and context when building universe substitution. +Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_034.v b/test-suite/bugs/closed/HoTT_coq_034.v new file mode 100644 index 00000000..8d5201f6 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_034.v @@ -0,0 +1,23 @@ +Module Short. + Set Universe Polymorphism. + Inductive relevant (A : Type) (B : Type) : Prop := . + Section foo. + Variables A B : Type. + Definition foo := prod (relevant A B) A. + End foo. + + Section bar. + Variable A : Type. + Variable B : Type. + Definition bar := prod (relevant A B) A. + End bar. + + Set Printing Universes. + Check bar nat Set : Set. (* success *) + Check foo nat Set : Set. (* Toplevel input, characters 6-17: +Error: +The term "foo (* Top.303 Top.304 *) nat Set" has type +"Type (* Top.304 *)" while it is expected to have type +"Set" (Universe inconsistency: Cannot enforce Top.304 = Set because Set +< Top.304)). *) +End Short. diff --git a/test-suite/bugs/closed/HoTT_coq_035.v b/test-suite/bugs/closed/HoTT_coq_035.v new file mode 100644 index 00000000..4ad2fc02 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_035.v @@ -0,0 +1,19 @@ +Fail Check Prop : Prop. (* Prop:Prop + : Prop *) +Fail Check Set : Prop. (* Set:Prop + : Prop *) +Fail Check ((bool -> Prop) : Prop). (* bool -> Prop:Prop + : Prop *) +Axiom proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2. +Check ((True : Prop) : Set). (* (True:Prop):Set + : Set *) +Goal (forall (v : Type) (f1 f0 : v -> Prop), + @eq (v -> Prop) f0 f1). +intros. +Fail apply proof_irrelevance. +admit. +Defined. (* Unnamed_thm is defined *) +Set Printing Universes. +Check ((True : Prop) : Set). (* Toplevel input, characters 0-28: +Error: Universe inconsistency (cannot enforce Prop <= Set because Set +< Prop). *) diff --git a/test-suite/bugs/closed/HoTT_coq_036.v b/test-suite/bugs/closed/HoTT_coq_036.v new file mode 100644 index 00000000..4c3e078a --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_036.v @@ -0,0 +1,135 @@ +Module Version1. + Set Implicit Arguments. + Set Universe Polymorphism. + Generalizable All Variables. + + Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj + }. + + Record > Category := + { + CObject : Type; + UnderlyingCategory :> @SpecializedCategory CObject + }. + + Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) := + { + ObjectOf :> objC -> objD + }. + + Definition Functor (C D : Category) := SpecializedFunctor C D. + + Parameter TerminalCategory : SpecializedCategory unit. + + Definition focus A (_ : A) := True. + + Definition CommaCategory_Object (A : Category) (S : Functor TerminalCategory A) : Type. + assert (Hf : focus ((S tt) = (S tt))) by constructor. + let C1 := constr:(CObject) in + let C2 := constr:(fun C => @Object (CObject C) C) in + unify C1 C2; idtac C1 C2. Show Universes. + progress change @CObject with (fun C => @Object (CObject C) C) in *. + simpl in *. + match type of Hf with + | focus ?V => exact V + end. + Defined. + + Definition Build_SliceCategory (A : Category) (F : Functor TerminalCategory A) := @Build_SpecializedCategory (CommaCategory_Object F). + Parameter SetCat : @SpecializedCategory Set. + + Set Printing Universes. + Check (fun (A : Category) (F : Functor TerminalCategory A) => @Build_SpecializedCategory (CommaCategory_Object F)) SetCat. + (* (fun (A : Category (* Top.68 *)) + (F : Functor (* Set Top.68 *) TerminalCategory A) => + {| |}) SetCat (* Top.68 *) + : forall + F : Functor (* Set Top.68 *) TerminalCategory SetCat (* Top.68 *), + let Object := CommaCategory_Object (* Top.68 Top.69 Top.68 *) F in + SpecializedCategory (* Top.69 *) + (CommaCategory_Object (* Top.68 Top.69 Top.68 *) F) *) + Check @Build_SliceCategory SetCat. (* Toplevel input, characters 0-34: +Error: Universe inconsistency (cannot enforce Top.51 <= Set because Set +< Top.51). *) +End Version1. + +Module Version2. + Set Implicit Arguments. + Set Universe Polymorphism. + + Record SpecializedCategory (obj : Type) := + { + Object : _ := obj + }. + + Record > Category := + { + CObject : Type; + UnderlyingCategory :> @SpecializedCategory CObject + }. + + Parameter TerminalCategory : SpecializedCategory unit. + + Definition focus A (_ : A) := True. + Parameter ObjectOf' : forall (objC : Type) (C : SpecializedCategory objC) + (objD : Type) (D : SpecializedCategory objD), Prop. + Definition CommaCategory_Object (A : Category) : Type. + assert (Hf : focus (@ObjectOf' _ (@Build_Category unit TerminalCategory) _ A)) by constructor. + progress change CObject with (fun C => @Object (CObject C) C) in *; + simpl in *. + match type of Hf with + | focus ?V => exact V + end. + Defined. + + Definition Build_SliceCategory := @CommaCategory_Object. + Parameter SetCat : @SpecializedCategory Set. + + Set Printing Universes. + Check @Build_SliceCategory SetCat. +End Version2. + +Module OtherBug. + Set Implicit Arguments. + Set Universe Polymorphism. + + Record SpecializedCategory (obj : Type) := + { + Object : _ := obj + }. + + Record > Category := + { + CObject : Type; + UnderlyingCategory :> @SpecializedCategory CObject + }. + + Parameter TerminalCategory : SpecializedCategory unit. + + Definition focus A (_ : A) := True. + + Parameter ObjectOf' : forall (objC : Type) (C : SpecializedCategory objC) + (objD : Type) (D : SpecializedCategory objD), Prop. + Definition CommaCategory_Object (A : Category@{i}) : Type. + assert (Hf : focus (@ObjectOf' _ (@Build_Category unit TerminalCategory) _ A)) by constructor. + progress change CObject with (fun C => @Object (CObject C) C) in *; + simpl in *. + match type of Hf with + | focus ?V => exact V + end. + Defined. + + Parameter SetCat : @SpecializedCategory Set. + + Set Printing Universes. + Definition Build_SliceCategory := @CommaCategory_Object. + Check @CommaCategory_Object SetCat. + (* CommaCategory_Object (* Top.43 Top.44 Top.43 *) SetCat (* Top.43 *) + : Type (* Top.44 *) *) + Check @Build_SliceCategory SetCat. + (* Toplevel input, characters 0-34: +Error: Universe inconsistency (cannot enforce Top.36 <= Set because Set +< Top.36). *) +End OtherBug. diff --git a/test-suite/bugs/closed/HoTT_coq_037.v b/test-suite/bugs/closed/HoTT_coq_037.v new file mode 100644 index 00000000..66476414 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_037.v @@ -0,0 +1,16 @@ +Set Printing Universes. + +Fixpoint CardinalityRepresentative (n : nat) : Set := + match n with + | O => Empty_set + | S n' => sum (CardinalityRepresentative n') unit + end. +(* Toplevel input, characters 104-143: +Error: +In environment +CardinalityRepresentative : nat -> Set +n : nat +n' : nat +The term "(CardinalityRepresentative n' + unit)%type" has type + "Type (* max(Top.73, Top.74) *)" while it is expected to have type +"Set". *) diff --git a/test-suite/bugs/closed/HoTT_coq_041.v b/test-suite/bugs/closed/HoTT_coq_041.v new file mode 100644 index 00000000..79933bb8 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_041.v @@ -0,0 +1,18 @@ +Set Printing All. +Definition foo (s d : Prop) + : ((s : Set) -> (d : Set)) = ((s : Prop) -> (d : Prop)) + := eq_refl. (* succeeds *) +Definition bar (s d : Prop) + : ((fun x : Set => x) s -> (fun x : Set => x) d) = ((fun x : Prop => x) s -> (fun x : Prop => x) d) + := eq_refl. (* Toplevel input, characters 131-138: +Error: +In environment +s : Prop +d : Prop +The term + "@eq_refl Set (forall _ : (fun x : Set => x) s, (fun x : Set => x) d)" +has type "@eq Set (forall _ : s, d) (forall _ : s, d)" +while it is expected to have type + "@eq Set (forall _ : s, d) (forall _ : s, d)" +(cannot unify "forall _ : (fun x : Set => x) s, (fun x : Set => x) d" and +"forall _ : (fun x : Prop => x) s, (fun x : Prop => x) d"). *) diff --git a/test-suite/bugs/closed/HoTT_coq_042.v b/test-suite/bugs/closed/HoTT_coq_042.v new file mode 100644 index 00000000..6b206a2f --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_042.v @@ -0,0 +1,27 @@ +Set Implicit Arguments. +Set Universe Polymorphism. +Generalizable All Variables. + +Record Category (obj : Type) := { Morphism : obj -> obj -> Type }. + +Definition SetCat : @Category Set := @Build_Category Set (fun s d => s -> d). + +Record Foo := { foo : forall A (f : Morphism SetCat A A), True }. + +Local Notation PartialBuild_Foo pf := (@Build_Foo (fun A f => pf A f)). + +Set Printing Universes. +Let SetCatFoo' : Foo. + let pf := fresh in + let pfT := fresh in + evar (pfT : Prop); + cut pfT; + [ subst pfT; intro pf; + let t := constr:(PartialBuild_Foo pf) in + let t' := (eval simpl in t) in + exact t' + | ]. + admit. +(* Toplevel input, characters 15-20: +Error: Universe inconsistency (cannot enforce Set <= Prop). + *) diff --git a/test-suite/bugs/closed/HoTT_coq_043.v b/test-suite/bugs/closed/HoTT_coq_043.v new file mode 100644 index 00000000..5257a032 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_043.v @@ -0,0 +1,15 @@ +Require Import Classes.RelationClasses List Setoid. + +Definition RowType := list Type. + +Inductive RowTypeDecidable (P : forall T, relation T) `(forall T, Equivalence (P T)) +: RowType -> Type := +| RTDecNil : RowTypeDecidable P _ nil +| RTDecCons : forall T Ts, (forall t0 t1 : T, + {P T t0 t1} + {~P T t0 t1}) + -> RowTypeDecidable P _ Ts + -> RowTypeDecidable P _ (T :: Ts). +(* Toplevel input, characters 15-378: +Error: +Last occurrence of "RowTypeDecidable" must have "H" as 2nd argument in + "RowTypeDecidable P (fun T : Type => H T) nil". *) diff --git a/test-suite/bugs/closed/HoTT_coq_044.v b/test-suite/bugs/closed/HoTT_coq_044.v new file mode 100644 index 00000000..c824f53b --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_044.v @@ -0,0 +1,35 @@ +Require Import Classes.RelationClasses List Setoid. + +Definition eqT (T : Type) := @eq T. + +Set Universe Polymorphism. + +Definition RowType := list Type. + + +Inductive Row : RowType -> Type := +| RNil : Row nil +| RCons : forall T Ts, T -> Row Ts -> Row (T :: Ts). + +Inductive RowTypeDecidable (P : forall T, relation T) `(H : forall T, Equivalence (P T)) +: RowType -> Type := +| RTDecNil : RowTypeDecidable P H nil +| RTDecCons : forall T Ts, (forall t0 t1 : T, + {P T t0 t1} + {~P T t0 t1}) + -> RowTypeDecidable P H Ts + -> RowTypeDecidable P H (T :: Ts). + + +Set Printing Universes. + +Fixpoint Row_eq (Ts : RowType) +: RowTypeDecidable (@eqT) _ Ts -> forall r1 r2 : Row Ts, {@eq (Row Ts) r1 r2} + {r1 <> r2}. +(* Toplevel input, characters 81-87: +Error: +In environment +Ts : RowType (* Top.53 Coq.Init.Logic.8 *) +r1 : Row (* Top.54 Top.55 *) Ts +r2 : Row (* Top.56 Top.57 *) Ts +The term "Row (* Coq.Init.Logic.8 Top.59 *) Ts" has type + "Type (* max(Top.58+1, Top.59) *)" while it is expected to have type + "Type (* Coq.Init.Logic.8 *)" (Universe inconsistency). *) diff --git a/test-suite/bugs/closed/HoTT_coq_045.v b/test-suite/bugs/closed/HoTT_coq_045.v new file mode 100644 index 00000000..00588ffb --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_045.v @@ -0,0 +1,53 @@ +Set Implicit Arguments. +Set Universe Polymorphism. +Generalizable All Variables. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj + }. + +Record > Category := + { + CObject : Type; + UnderlyingCategory :> @SpecializedCategory CObject + }. + +Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) := + { + ObjectOf :> objC -> objD + }. + +Definition Functor (C D : Category) := SpecializedFunctor C D. + +Parameter TerminalCategory : SpecializedCategory unit. + +Definition focus A (_ : A) := True. + +Definition CommaCategory_Object (A : Category) (S : Functor TerminalCategory A) : Type. + assert (Hf : focus ((S tt) = (S tt))) by constructor. + let C1 := constr:(CObject) in + let C2 := constr:(fun C => @Object (CObject C) C) in + unify C1 C2. + progress change CObject with (fun C => @Object (CObject C) C) in *. + simpl in *. + let V := match type of Hf with + | focus ?V => constr:(V) + end + in exact V. +(* Toplevel input, characters 89-96: +Error: Illegal application: +The term "ObjectOf" of type + "forall (objC : Set) (C : SpecializedCategory objC) + (objD : Type) (D : SpecializedCategory objD), + SpecializedFunctor C D -> objC -> objD" +cannot be applied to the terms + "Object TerminalCategory" : "Type" + "TerminalCategory" : "SpecializedCategory unit" + "Object A" : "Type" + "UnderlyingCategory A" : "SpecializedCategory (CObject A)" + "S" : "Functor TerminalCategory A" + "tt" : "unit" +The 1st term has type "Type" which should be coercible to +"Set". *) +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_047.v b/test-suite/bugs/closed/HoTT_coq_047.v new file mode 100644 index 00000000..29496be5 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_047.v @@ -0,0 +1,46 @@ +Inductive nCk : nat -> nat -> Type := + |zz : nCk 0 0 + | incl { m n : nat } : nCk m n -> nCk (S m) (S n) + | excl { m n : nat } : nCk m n -> nCk (S m) n. + +Definition nCkComp { l m n : nat } : + nCk l m -> nCk m n -> nCk l n. +Proof. + intro. + revert n. + induction H. + auto. +(* ( incl w ) o zz -> contradiction *) + intros. + remember (S n) as sn. + destruct H0. + discriminate Heqsn. + apply incl. + apply IHnCk. + injection Heqsn. + intro. + rewrite <- H1. + auto. + apply excl. + apply IHnCk. + injection Heqsn. + intro. rewrite <- H1. + auto. + intros. + apply excl. + apply IHnCk. + auto. +Defined. + +Lemma nCkEq { k l m n : nat } ( cs : nCk k l ) (ct : nCk l m) (cr : nCk m n ): + nCkComp cs (nCkComp ct cr) = nCkComp (nCkComp cs ct) cr. +Proof. + revert m n ct cr. + induction cs. + intros. simpl. auto. + intros. + destruct n. + destruct m0. + destruct n0. + destruct cr. +(* Anomaly: Evar ?nnn was not declared. Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_048.v b/test-suite/bugs/closed/HoTT_coq_048.v new file mode 100644 index 00000000..831bb3fc --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_048.v @@ -0,0 +1,7 @@ +(** This is not the issue of https://github.com/HoTT/coq/issues/48, but was mentioned there. *) +Record Foo := + { + foo := 1; + bar : foo = foo + }. +(* Anomaly: lookup_projection: constant is not a projection. Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_049.v b/test-suite/bugs/closed/HoTT_coq_049.v new file mode 100644 index 00000000..906ec329 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_049.v @@ -0,0 +1,6 @@ +Require Import FunctionalExtensionality. + +Goal forall y, @f_equal = y. +intro. +apply functional_extensionality_dep. +(* Error: Ill-typed evar instance in HoTT/coq, Anomaly: Uncaught exception Reductionops.NotASort(_). Please report. before that. *) diff --git a/test-suite/bugs/closed/HoTT_coq_050.v b/test-suite/bugs/closed/HoTT_coq_050.v new file mode 100644 index 00000000..ce9b6b29 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_050.v @@ -0,0 +1,33 @@ +Set Implicit Arguments. +Generalizable All Variables. +Set Asymmetric Patterns. +Set Universe Polymorphism. +Set Printing Universes. + +Set Printing All. + +Record PreCategory := + { + Object :> Type; + Morphism : Object -> Object -> Type + }. + +Inductive paths A (x : A) : A -> Type := idpath : @paths A x x. +Inductive Unit : Prop := tt. (* Changing this to [Set] fixes things *) +Inductive Bool : Set := true | false. + +Definition DiscreteCategory X : PreCategory + := @Build_PreCategory X + (@paths X). + +Definition IndiscreteCategory X : PreCategory + := @Build_PreCategory X + (fun _ _ => Unit). + +Check (IndiscreteCategory Unit). +Check (DiscreteCategory Bool). +Definition NatCategory (n : nat) := + match n with + | 0 => IndiscreteCategory Unit + | _ => DiscreteCategory Bool + end. (* Error: Universe inconsistency (cannot enforce Set <= Prop). *) diff --git a/test-suite/bugs/closed/HoTT_coq_052.v b/test-suite/bugs/closed/HoTT_coq_052.v new file mode 100644 index 00000000..62bb9fa1 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_052.v @@ -0,0 +1,22 @@ +Goal Type = Type. + Fail match goal with |- ?x = ?x => idtac end. +Abort. + +Goal Prop. + Fail match goal with |- Type => idtac end. +Abort. + +Goal Prop = Set. + (* This should fail *) + Fail match goal with |- ?x = ?x => idtac x end. +Abort. + +Goal Type = Prop. + (* This should fail *) + Fail match goal with |- ?x = ?x => idtac end. +Abort. + +Goal Type = Set. + (* This should fail *) + Fail match goal with |- ?x = ?x => idtac end. +Abort. diff --git a/test-suite/bugs/closed/HoTT_coq_053.v b/test-suite/bugs/closed/HoTT_coq_053.v new file mode 100644 index 00000000..a14fb6aa --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_053.v @@ -0,0 +1,50 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +Set Printing Universes. +Set Implicit Arguments. +Generalizable All Variables. +Set Asymmetric Patterns. +Set Universe Polymorphism. + +Inductive Unit : Type := + tt : Unit. + +Inductive Bool : Type := + | true : Bool + | false : Bool. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Record PreCategory := + { + Object :> Type; + Morphism : Object -> Object -> Type + }. + +Definition DiscreteCategory X : PreCategory + := @Build_PreCategory X + (@paths X). + +Definition IndiscreteCategory X : PreCategory + := @Build_PreCategory X + (fun _ _ => Unit). + +Definition NatCategory (n : nat) := + match n with + | 0 => IndiscreteCategory Unit + | _ => DiscreteCategory Bool + end. +(* Error: Universe inconsistency (cannot enforce Set <= Prop).*) + +Definition NatCategory' (n : nat) := + match n with + | 0 => (fun X => @Build_PreCategory X + (fun _ _ => Unit : Prop)) Unit + | _ => DiscreteCategory Bool + end. + +Definition NatCategory'' (n : nat) := + match n with + | 0 => IndiscreteCategory Unit + | _ => DiscreteCategory Bool + end. diff --git a/test-suite/bugs/closed/HoTT_coq_054.v b/test-suite/bugs/closed/HoTT_coq_054.v new file mode 100644 index 00000000..c6879659 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_054.v @@ -0,0 +1,94 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs") -*- *) +Inductive Empty : Prop := . + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Arguments idpath {A a} , [A] a. + +Definition idmap {A : Type} : A -> A := fun x => x. + +Definition path_sum {A B : Type} (z z' : A + B) + (pq : match z, z' with + | inl z0, inl z'0 => z0 = z'0 + | inr z0, inr z'0 => z0 = z'0 + | _, _ => Empty + end) +: z = z'. + destruct z, z', pq; exact idpath. +Defined. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Theorem ex2_8 {A B A' B' : Type} (g : A -> A') (h : B -> B') (x y : A + B) + (* Fortunately, this unifies properly *) + (pq : match (x, y) with (inl x', inl y') => x' = y' | (inr x', inr y') => x' = y' | _ => Empty end) : + let f z := match z with inl z' => inl (g z') | inr z' => inr (h z') end in + ap f (path_sum x y pq) = path_sum (f x) (f y) + (* Coq appears to require *ALL* of the annotations *) + ((match x as x return match (x, y) with + (inl x', inl y') => x' = y' + | (inr x', inr y') => x' = y' + | _ => Empty + end -> match (f x, f y) with + | (inl x', inl y') => x' = y' + | (inr x', inr y') => x' = y' + | _ => Empty end with + | inl x' => match y as y return match y with + inl y' => x' = y' + | _ => Empty + end -> match f y with + | inl y' => g x' = y' + | _ => Empty end with + | inl y' => ap g + | inr y' => idmap + end + | inr x' => match y as y return match y return Prop with + inr y' => x' = y' + | _ => Empty + end -> match f y return Prop with + | inr y' => h x' = y' + | _ => Empty end with + | inl y' => idmap + | inr y' => ap h + end + end) pq). + destruct x; destruct y; destruct pq; reflexivity. +Qed. +(* Toplevel input, characters 1367-1374: +Error: +In environment +A : Type +B : Type +A' : Type +B' : Type +g : A -> A' +h : B -> B' +x : A + B +y : A + B +pq : +match x with +| inl x' => match y with + | inl y' => x' = y' + | inr _ => Empty + end +| inr x' => match y with + | inl _ => Empty + | inr y' => x' = y' + end +end +f := +fun z : A + B => +match z with +| inl z' => inl (g z') +| inr z' => inr (h z') +end : A + B -> A' + B' +x' : B +y0 : A + B +y' : B +The term "x' = y'" has type "Type" while it is expected to have type +"Prop" (Universe inconsistency). *) diff --git a/test-suite/bugs/closed/HoTT_coq_055.v b/test-suite/bugs/closed/HoTT_coq_055.v new file mode 100644 index 00000000..92d70ad1 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_055.v @@ -0,0 +1,53 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +Set Universe Polymorphism. + +Inductive Empty : Prop := . + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Arguments idpath {A a} , [A] a. + +Definition idmap {A : Type} : A -> A := fun x => x. + +Definition path_sum {A B : Type} (z z' : A + B) + (pq : match z, z' with + | inl z0, inl z'0 => z0 = z'0 + | inr z0, inr z'0 => z0 = z'0 + | _, _ => Empty + end) +: z = z'. + + admit. +Defined. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Theorem ex2_8 {A B A' B' : Type} (g : A -> A') (h : B -> B') (x y : A + B) + + (pq : match (x, y) with (inl x', inl y') => x' = y' | (inr x', inr y') => x' = y' | _ => Empty end) : + let f z := match z with inl z' => inl (g z') | inr z' => inr (h z') end in + ap f (path_sum x y pq) = path_sum (f x) (f y) + ((match x as x return match (x, y) with + (inl x', inl y') => x' = y' + | (inr x', inr y') => x' = y' + | _ => Empty + end -> match (f x, f y) with + | (inl x', inl y') => x' = y' + | (inr x', inr y') => x' = y' + | _ => Empty end with + | inl x' => match y with + | inl y' => ap g + | inr y' => idmap + end + | inr x' => match y with + | inl y' => idmap + | inr y' => ap h + end + end) pq). + +Admitted. +(* Toplevel input, characters 20-29: +Error: Matching on term "f y" of type "A' + B'" expects 2 branches. *) diff --git a/test-suite/bugs/closed/HoTT_coq_056.v b/test-suite/bugs/closed/HoTT_coq_056.v new file mode 100644 index 00000000..6e65320d --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_056.v @@ -0,0 +1,156 @@ +(* File reduced by coq-bug-finder from 10455 lines to 8350 lines, then from 7790 lines to 710 lines, then from 7790 lines to 710 lines, then from 566 lines to 340 lines, then from 191 lines to 171 lines, then from 191 lines to 171 lines. *) + +Set Implicit Arguments. +Set Universe Polymorphism. +Definition admit {T} : T. +Admitted. +Reserved Notation "x ≅ y" (at level 70, no associativity). +Reserved Notation "i ^op" (at level 3). +Reserved Infix "∘" (at level 40, left associativity). +Reserved Notation "F ⟨ x ⟩" (at level 10, no associativity, x at level 10). +Reserved Notation "F ⟨ x , y ⟩" (at level 10, no associativity, x at level 10, y at level 10). +Reserved Notation "F ⟨ ─ ⟩" (at level 10, no associativity). +Reserved Notation "F ⟨ x , ─ ⟩" (at level 10, no associativity, x at level 10). +Reserved Notation "F ⟨ ─ , y ⟩" (at level 10, no associativity, y at level 10). +Delimit Scope object_scope with object. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope functor_scope with functor. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Delimit Scope path_scope with path. +Local Open Scope path_scope. + +Record PreCategory := + Build_PreCategory' { + Object :> Type; + Morphism : Object -> Object -> Type + }. + +Bind Scope category_scope with PreCategory. + +Definition Build_PreCategory + Object Morphism + := @Build_PreCategory' Object + Morphism. + +Record Functor (C D : PreCategory) := + { + ObjectOf :> C -> D; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. +Arguments MorphismOf [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. +Class Isomorphic {C : PreCategory} (s d : C) := {}. +Definition ComposeFunctors C D E (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor C E + (fun c => G (F c)) + (fun _ _ m => G.(MorphismOf) (F.(MorphismOf) m)). + +Infix "∘" := ComposeFunctors : functor_scope. + +Definition IdentityFunctor C : Functor C C + := Build_Functor C C + (fun x => x) + (fun _ _ x => x). + +Notation "─" := (IdentityFunctor _) : functor_scope. +Record NaturalTransformation C D (F G : Functor C D) := + Build_NaturalTransformation' { }. + +Definition OppositeCategory (C : PreCategory) : PreCategory + := @Build_PreCategory' C + (fun s d => Morphism C d s). + +Notation "C ^op" := (OppositeCategory C) : category_scope. + +Definition ProductCategory (C D : PreCategory) : PreCategory + := @Build_PreCategory (C * D)%type + (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type). + +Infix "*" := ProductCategory : category_scope. + +Definition OppositeFunctor C D (F : Functor C D) : Functor (C ^op) (D ^op) + := Build_Functor (C ^op) (D ^op) + (ObjectOf F) + (fun s d => MorphismOf F (s := d) (d := s)). +Notation "F ^op" := (OppositeFunctor F) : functor_scope. + +Definition FunctorProduct' C D C' D' (F : Functor C D) (F' : Functor C' D') : Functor (C * C') (D * D') + := admit. + +Global Class FunctorApplicationInterpretable + {C D} (F : Functor C D) + {argsT : Type} (args : argsT) + {T : Type} (rtn : T) + := {}. +Definition FunctorApplicationOf {C D} F {argsT} args {T} {rtn} + `{@FunctorApplicationInterpretable C D F argsT args T rtn} + := rtn. + +Global Arguments FunctorApplicationOf / {C} {D} F {argsT} args {T} {rtn} {_}. + +Global Instance FunctorApplicationDash C D (F : Functor C D) +: FunctorApplicationInterpretable F (IdentityFunctor C) F | 0. +Global Instance FunctorApplicationFunctorFunctor' A B C C' D (F : Functor (A * B) D) (G : Functor C A) (H : Functor C' B) +: FunctorApplicationInterpretable F (G, H) (F ∘ (FunctorProduct' G H))%functor | 100. + +Notation "F ⟨ x ⟩" := (FunctorApplicationOf F%functor x%functor) : functor_scope. + +Notation "F ⟨ x , y ⟩" := (FunctorApplicationOf F%functor (x%functor , y%functor)) : functor_scope. + +Notation "F ⟨ ─ ⟩" := (F ⟨ ( ─ ) ⟩)%functor : functor_scope. + +Notation "F ⟨ x , ─ ⟩" := (F ⟨ x , ( ─ ) ⟩)%functor : functor_scope. + +Notation "F ⟨ ─ , y ⟩" := (F ⟨ ( ─ ) , y ⟩)%functor : functor_scope. + +Definition FunctorCategory (C D : PreCategory) : PreCategory + := @Build_PreCategory (Functor C D) + (NaturalTransformation (C := C) (D := D)). + +Notation "[ C , D ]" := (FunctorCategory C D) : category_scope. + +Definition SetCat : PreCategory := @Build_PreCategory Type (fun x y => x -> y). + +Definition HomFunctor C : Functor (C^op * C) SetCat. +admit. +Defined. +Definition NaturalIsomorphism (C D : PreCategory) F G := @Isomorphic [C, D] F G. +Infix "≅" := NaturalIsomorphism : natural_transformation_scope. + +Local Open Scope functor_scope. +Local Open Scope natural_transformation_scope. + +Section Adjunction. + Variable C : PreCategory. + Variable D : PreCategory. + + Variable F : Functor C D. + Variable G : Functor D C. + Let Adjunction_Type := Eval simpl in HomFunctor D ⟨ F^op ⟨ ─ ⟩ , ─ ⟩ ≅ HomFunctor C ⟨ ─ , G ⟨ ─ ⟩ ⟩. + Record Adjunction := { AMateOf : Adjunction_Type }. +End Adjunction. + +Section AdjunctionEquivalences. + Variable C : PreCategory. + Variable D : PreCategory. + + Variable F : Functor C D. + Variable G : Functor D C. + Variable A : Adjunction F G. + Set Printing All. + Definition foo := @AMateOf C D F G A. +(* File "./HoTT_coq_56.v", line 145, characters 37-38: +Error: +In environment +C : PreCategory +D : PreCategory +F : Functor C D +G : Functor D C +A : @Adjunction C D F G +The term "A" has type "@Adjunction C D F G" while it is expected to have type + "@Adjunction C D F G". *) +End AdjunctionEquivalences. diff --git a/test-suite/bugs/closed/HoTT_coq_057.v b/test-suite/bugs/closed/HoTT_coq_057.v new file mode 100644 index 00000000..e72ce0c5 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_057.v @@ -0,0 +1,33 @@ +Require Export Coq.Lists.List. + +Polymorphic Fixpoint LIn (A : Type) (a:A) (l:list A) : Type := + match l with + | nil => False + | b :: m => (b = a) + LIn A a m + end. + +Polymorphic Inductive NTerm : Type := +| cterm : NTerm +| oterm : list NTerm -> NTerm. + +Polymorphic Fixpoint dummy {A B} (x : list (A * B)) : list (A * B) := + match x with + | nil => nil + | (_, _) :: _ => nil + end. + +Lemma foo : + forall v t sub vars, + LIn (nat * NTerm) (v, t) (dummy sub) + -> + ( + LIn (nat * NTerm) (v, t) sub + * + notT (LIn nat v vars) + ). +Proof. + induction sub; simpl; intros. + destruct H. + Set Printing Universes. + try (apply IHsub in X). (* Toplevel input, characters 5-21: +Error: Universe inconsistency (cannot enforce Top.47 = Set). *) diff --git a/test-suite/bugs/closed/HoTT_coq_058.v b/test-suite/bugs/closed/HoTT_coq_058.v new file mode 100644 index 00000000..9ce7dba9 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_058.v @@ -0,0 +1,140 @@ +(* File reduced by coq-bug-finder from 10044 lines to 493 lines, then from 425 lines to 160 lines. *) +Set Universe Polymorphism. +Notation idmap := (fun x => x). +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. +Notation "x .1" := (projT1 x) (at level 3) : fibration_scope. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Delimit Scope path_scope with path. +Local Open Scope path_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) +: forall x, f x = g x + := fun x => match h with idpath => idpath end. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }. + +Delimit Scope equiv_scope with equiv. +Local Open Scope equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. + +Class Funext := { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. + +Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : + (forall x, f x = g x) -> f = g + := (@apD10 A P f g)^-1. + +Inductive Unit : Set := + tt : Unit. + +Definition path_prod_uncurried {A B : Type} (z z' : A * B) + (pq : (fst z = fst z') * (snd z = snd z')) +: (z = z') + := match pq with (p,q) => + match z, z' return + (fst z = fst z') -> (snd z = snd z') -> (z = z') with + | (a,b), (a',b') => fun p q => + match p, q with + idpath, idpath => idpath + end + end p q + end. + +Definition path_prod {A B : Type} (z z' : A * B) : + (fst z = fst z') -> (snd z = snd z') -> (z = z') + := fun p q => path_prod_uncurried z z' (p,q). + +Definition path_prod' {A B : Type} {x x' : A} {y y' : B} +: (x = x') -> (y = y') -> ((x,y) = (x',y')) + := fun p q => path_prod (x,y) (x',y') p q. + +Lemma path_forall_recr_beta `{Funext} A B x0 P f g e Px +: @transport (forall a : A, B a) + (fun f => P f (f x0)) + f + g + (@path_forall _ _ _ _ _ e) + Px + = @transport ((forall a, B a) * B x0)%type + (fun x => P (fst x) (snd x)) + (f, f x0) + (g, g x0) + (path_prod' (@path_forall _ _ _ _ _ e) (e x0)) + Px. + + admit. +Defined. +Definition transport_path_prod'_beta' A B P (x x' : A) (y y' : B) (HA : x = x') (HB : y = y') (Px : P x y) +: @transport (A * B) (fun xy => P (fst xy) (snd xy)) (x, y) (x', y') (@path_prod' A B x x' y y' HA HB) Px + = @transport A (fun x => P x y') x x' HA + (@transport B (fun y => P x y) y y' HB Px). + admit. +Defined. +Goal forall (T : Type) (T0 : T -> T -> Type) + (Pmor : forall s d : T, T0 s d -> Type) (x x0 : T) + (x1 : T0 x x0) (p : Pmor x x0 x1) (H : Funext), + transport + (fun x2 : {_ : T & Unit} -> {_ : T & Unit} => + { x1 : _ & Pmor (x2 (x; tt)) .1 (x2 (x0; tt)) .1 x1}) + (path_forall (fun c : {_ : T & Unit} => (c .1; tt)) idmap + (fun x2 : {_ : T & Unit} => + let (x3, y) as s return ((s .1; tt) = s) := x2 in + match y as y0 return ((x3; tt) = (x3; y0)) with + | tt => idpath + end)) (x1; p) = (x1; p). +intros. +let F := match goal with |- appcontext[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(F) end in +let H := match goal with |- appcontext[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(H) end in +let X := match goal with |- appcontext[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(X) end in +let T := match goal with |- appcontext[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(T) end in +let t0 := fresh "t0" in +let t1 := fresh "t1" in +let T1 := lazymatch type of F with (?T -> _) -> _ => constr:(T) end in + evar (t1 : T1); + let T0 := lazymatch type of F with (forall a : ?A, @?B a) -> ?C => constr:((forall a : A, B a) -> B t1 -> C) end in + evar (t0 : T0); + + let dummy := fresh in + assert (dummy : forall x0, F x0 = t0 x0 (x0 t1)); + [ let x0 := fresh in + intro x0; + simpl in *; + let GL0 := lazymatch goal with |- ?GL0 = _ => constr:(GL0) end in + let GL0' := fresh in + let GL1' := fresh in + set (GL0' := GL0); + + let arg := match GL0 with appcontext[x0 ?arg] => constr:(arg) end in + assert (t1 = arg) by (subst t1; reflexivity); subst t1; + pattern (x0 arg) in GL0'; + match goal with + | [ GL0'' := ?GR _ |- _ ] => constr_eq GL0' GL0''; + pose GR as GL1' + end; + + pattern x0 in GL1'; + match goal with + | [ GL1'' := ?GR _ |- _ ] => constr_eq GL1' GL1''; + assert (t0 = GR) + end; + subst t0; [ reflexivity | reflexivity ] + | clear dummy ]; + let p := fresh in + pose (@path_forall_recr_beta H X T t1 t0) as p; + simpl in *; + rewrite p; + subst t0 t1 p. + rewrite transport_path_prod'_beta'. + (* Anomaly: Uncaught exception Invalid_argument("to_constraints: non-trivial algebraic constraint between universes", _). +Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_059.v b/test-suite/bugs/closed/HoTT_coq_059.v new file mode 100644 index 00000000..9c7e394d --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_059.v @@ -0,0 +1,17 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +Set Universe Polymorphism. + +Inductive eq {A} (x : A) : A -> Type := eq_refl : eq x x. +Notation "a = b" := (eq a b) : type_scope. + +Section foo. + Class Funext := { path_forall :> forall A P (f g : forall x : A, P x), (forall x, f x = g x) -> f = g }. + Context `{Funext, Funext}. + + Set Printing Universes. + + (** Typeclass resolution should pick up the different instances of Funext automatically *) + Definition foo := (@path_forall _ _ _ (@path_forall _ Set)). + (* Toplevel input, characters 0-60: +Error: Universe inconsistency (cannot enforce Top.24 <= Top.23 because Top.23 +< Top.22 <= Top.24). *) diff --git a/test-suite/bugs/closed/HoTT_coq_061.v b/test-suite/bugs/closed/HoTT_coq_061.v new file mode 100644 index 00000000..26c1f963 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_061.v @@ -0,0 +1,132 @@ +(* There are some problems in materialize_evar with local definitions, + as CO below; this is not completely sorted out yet, but at least + it fails in a smooth way at the time of today [HH] *) + +(* File reduced by coq-bug-finder from 9039 lines to 7786 lines, then + from 7245 lines to 476 lines, then from 417 lines to 249 lines, + then from 171 lines to 127 lines. *) + +Set Implicit Arguments. +Set Universe Polymorphism. +Definition admit {T} : T. +Admitted. +Delimit Scope object_scope with object. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope functor_scope with functor. +Delimit Scope natural_transformation_scope with natural_transformation. +Reserved Infix "o" (at level 40, left associativity). +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Record PreCategory := + { + Object :> Type; + Morphism : Object -> Object -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' where "f 'o' g" := (Compose f g) + }. +Bind Scope category_scope with PreCategory. + +Arguments Compose [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + +Infix "o" := Compose : morphism_scope. +Local Open Scope morphism_scope. + +Record Functor (C D : PreCategory) := + { + ObjectOf :> C -> D; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d); + FCompositionOf : forall s d d' (m1 : C.(Morphism) s d) (m2: C.(Morphism) d d'), + MorphismOf _ _ (m2 o m1) = (MorphismOf _ _ m2) o (MorphismOf _ _ m1) + }. + +Bind Scope functor_scope with Functor. + +Arguments MorphismOf [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. + +Definition ComposeFunctors C D E + (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor C E + (fun c => G (F c)) + admit + admit. + +Infix "o" := ComposeFunctors : functor_scope. + +Record NaturalTransformation C D (F G : Functor C D) := + { + ComponentsOf :> forall c, D.(Morphism) (F c) (G c); + Commutes : forall s d (m : C.(Morphism) s d), + ComponentsOf d o F.(MorphismOf) m = G.(MorphismOf) m o ComponentsOf s + }. + +Generalizable All Variables. + +Section NTComposeT. + + Variable C : PreCategory. + Variable D : PreCategory. + + Variables F F' F'' : Functor C D. + + Variable T' : NaturalTransformation F' F''. + Variable T : NaturalTransformation F F'. + Let CO := fun c => T' c o T c. + Definition NTComposeT_Commutes s d (m : Morphism C s d) + : CO d o MorphismOf F m = MorphismOf F'' m o CO s. + + admit. + Defined. + Definition NTComposeT + : NaturalTransformation F F'' + := Build_NaturalTransformation F F'' + (fun c => T' c o T c) + NTComposeT_Commutes. +End NTComposeT. +Definition NTWhiskerR C D E (F F' : Functor D E) (T : NaturalTransformation F F') + (G : Functor C D) + := Build_NaturalTransformation (F o G) (F' o G) + (fun c => T (G c)) + admit. +Global Class NTC_Composable A B (a : A) (b : B) (T : Type) (term : T) := {}. + +Definition NTC_Composable_term `{@NTC_Composable A B a b T term} := term. +Notation "T 'o' U" + := (@NTC_Composable_term _ _ T%natural_transformation U%natural_transformation _ _ _) + : natural_transformation_scope. + +Local Open Scope natural_transformation_scope. + +Lemma NTWhiskerR_CompositionOf C D + (F G H : Functor C D) + (T : NaturalTransformation G H) + (T' : NaturalTransformation F G) B (I : Functor B C) +: NTWhiskerR (NTComposeT T T') I = NTComposeT (NTWhiskerR T I) (NTWhiskerR T' I). + + admit. +Defined. +Definition FunctorCategory C D : PreCategory + := @Build_PreCategory (Functor C D) + (NaturalTransformation (C := C) (D := D)) + admit. + +Notation "[ C , D ]" := (FunctorCategory C D) : category_scope. + +Variable C : PreCategory. +Variable D : PreCategory. +Variable E : PreCategory. +Fail Definition NTWhiskerR_Functorial (G : [C, D]%category) +: [[D, E], [C, E]]%category + := Build_Functor + [C, D] [C, E] + (fun F => F o G) + (fun _ _ T => T o G) + (fun _ _ _ _ _ => inverse (NTWhiskerR_CompositionOf _ _ _)). +(* Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_062.v b/test-suite/bugs/closed/HoTT_coq_062.v new file mode 100644 index 00000000..db895316 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_062.v @@ -0,0 +1,106 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* File reduced by coq-bug-finder from 5012 lines to 4659 lines, then from 4220 lines to 501 lines, then from 513 lines to 495 lines, then from 513 lines to 495 lines, then from 412 lines to 79 lines, then from 412 lines to 79 lines. *) +Set Universe Polymorphism. +Definition admit {T} : T. +Admitted. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Delimit Scope path_scope with path. +Local Open Scope path_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition apD {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y): + p # (f x) = f y + := + match p with idpath => idpath end. + +Class IsEquiv {A B : Type} (f : A -> B) := + BuildIsEquiv { + equiv_inv : B -> A + }. + +Record Equiv A B := + BuildEquiv { + equiv_fun :> A -> B ; + equiv_isequiv :> IsEquiv equiv_fun + }. + +Existing Instance equiv_isequiv. + +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. + +Inductive Bool : Type := true | false. + +Local Open Scope equiv_scope. +Definition equiv_path (A B : Type) (p : A = B) : A <~> B + := BuildEquiv _ _ (transport (fun X:Type => X) p) admit. + +Class Univalence := + isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B) . + +Section Univalence. + Context `{Univalence}. + Definition path_universe_uncurried {A B : Type} (f : A <~> B) : A = B + := (equiv_path A B)^-1 f. + + Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B) + := path_universe_uncurried (BuildEquiv _ _ f feq). +End Univalence. + +Definition e : Equiv@{i j} Bool Bool. + admit. +Defined. + +Definition p `{Univalence} : @paths Type Bool Bool := path_universe e. + +Theorem thm `{Univalence} : (forall A, ((A -> False) -> False) -> A) -> False. + intro f. + Set Printing Universes. + Set Printing All. + Show Universes. + pose proof (apD f p). + pose proof (apD f (path_universe e)). + admit. +Defined. (* ??? Toplevel input, characters 0-37: +Error: +Unable to satisfy the following constraints: +In environment: +H : Univalence@{Top.144 Top.145 Top.146 Top.147 Top.148} +f : forall (A : Type{Top.150}) (_ : forall _ : forall _ : A, False, False), A + +?57 : "@IsEquiv@{Top.150 Top.145} Bool Bool (equiv_fun@{Set Set} Bool Bool e)" *) +(* Toplevel input, characters 18-19: +Error: +In environment +H : Univalence (* Top.148 Top.149 Top.150 Top.151 *) +f : forall (A : Type (* Top.153 *)) + (_ : forall _ : forall _ : A, False, False), A +X : @paths (* Top.155 *) + ((fun A : Type (* Top.153 *) => + forall _ : forall _ : forall _ : A, False, False, A) Bool) + (@transport (* Top.154 Top.155 *) Type (* Top.153 *) + (fun A : Type (* Top.153 *) => + forall _ : forall _ : forall _ : A, False, False, A) Bool Bool + (@path_universe (* Top.148 Top.150 Top.151 Top.159 Top.153 Top.154 + Top.149 Top.153 *) H Bool Bool + (equiv_fun (* Top.153 Top.153 *) Bool Bool e (* Top.153 *)) + (equiv_isequiv (* Top.153 Top.153 *) Bool Bool e (* Top.153 *))) + (f Bool)) (f Bool) +The term "@p (* Top.148 Top.172 Top.151 Top.150 Top.149 *) H" has type + "@paths (* Top.171 *) Set Bool Bool" while it is expected to have type + "@paths (* Top.169 *) Type (* Top.153 *) ?62 ?63" +(Universe inconsistency: Cannot enforce Set = Top.153)). *) diff --git a/test-suite/bugs/closed/HoTT_coq_063.v b/test-suite/bugs/closed/HoTT_coq_063.v new file mode 100644 index 00000000..777f6483 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_063.v @@ -0,0 +1,34 @@ +Set Universe Polymorphism. +Module A. + Inductive paths A (x : A) : A -> Type := idpath : paths A x x. + + Notation "x = y" := (paths _ x y). + + Inductive IsTrunc : nat -> Type -> Type := + | BuildContr : forall A (center : A) (contr : forall y, center = y), IsTrunc 0 A + | trunc_S : forall A n, (forall x y : A, IsTrunc n (x = y)) -> IsTrunc (S n) A. + + Existing Class IsTrunc. + + + Instance is_trunc_unit : IsTrunc 0 unit. + Proof. apply BuildContr with (center:=tt). now intros []. Defined. + + Check (_ : IsTrunc 0 unit). +End A. + +Module B. + Fixpoint IsTrunc (n : nat) (A : Type) : Type := + match n with + | O => True + | S _ => False + end. + + Existing Class IsTrunc. + + Instance is_trunc_unit : IsTrunc 0 unit. + Proof. exact I. Defined. + + Check (_ : IsTrunc 0 unit). + Fail Definition foo := (_ : IsTrunc 1 unit). +End B. diff --git a/test-suite/bugs/closed/HoTT_coq_064.v b/test-suite/bugs/closed/HoTT_coq_064.v new file mode 100644 index 00000000..5f0a541b --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_064.v @@ -0,0 +1,190 @@ +(* File reduced by coq-bug-finder from 279 lines to 219 lines. *) + +Set Implicit Arguments. +Set Universe Polymorphism. +Definition admit {T} : T. +Admitted. +Module Export Overture. + Reserved Notation "g 'o' f" (at level 40, left associativity). + + Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + + Arguments idpath {A a} , [A] a. + + Notation "x = y :> A" := (@paths A x y) : type_scope. + + Notation "x = y" := (x = y :>_) : type_scope. + + Delimit Scope path_scope with path. + + Local Open Scope path_scope. + + Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + + Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) + : forall x, f x = g x + := fun x => match h with idpath => idpath end. + + Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }. + + Delimit Scope equiv_scope with equiv. + Local Open Scope equiv_scope. + + Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. + + Class Funext. + Axiom isequiv_apD10 : `{Funext} -> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) . + Existing Instance isequiv_apD10. + + Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : + (forall x, f x = g x) -> f = g + := + (@apD10 A P f g)^-1. + +End Overture. + +Module Export Core. + + Set Implicit Arguments. + Delimit Scope morphism_scope with morphism. + Delimit Scope category_scope with category. + Delimit Scope object_scope with object. + + Record PreCategory := + { + object :> Type; + morphism : object -> object -> Type; + + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1) + }. + Bind Scope category_scope with PreCategory. + Arguments compose [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + + Infix "o" := compose : morphism_scope. + +End Core. + +Local Open Scope morphism_scope. +Record Functor (C D : PreCategory) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d) + }. + +Inductive Unit : Set := + tt : Unit. + +Definition indiscrete_category (X : Type) : PreCategory + := @Build_PreCategory X + (fun _ _ => Unit) + (fun _ _ _ _ _ => tt) + (fun _ _ _ _ _ _ _ => idpath). + + +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. +Section path_natural_transformation. + Context `{Funext}. + Variable C : PreCategory. + Variable D : PreCategory. + Variables F G : Functor C D. + + Section path. + Variables T U : NaturalTransformation F G. + Lemma path'_natural_transformation + : components_of T = components_of U + -> T = U. + admit. + Defined. + Lemma path_natural_transformation + : (forall x, T x = U x) + -> T = U. + Proof. + intros. + apply path'_natural_transformation. + apply path_forall; assumption. + Qed. + End path. +End path_natural_transformation. +Ltac path_natural_transformation := + repeat match goal with + | _ => intro + | _ => apply path_natural_transformation; simpl + end. +Definition comma_category A B C (S : Functor A C) (T : Functor B C) +: PreCategory. + admit. +Defined. +Definition compose C D (F F' F'' : Functor C D) + (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F') +: NaturalTransformation F F'' + := Build_NaturalTransformation F F'' + (fun c => T' c o T c). + +Infix "o" := compose : natural_transformation_scope. + +Local Open Scope natural_transformation_scope. + +Definition associativity `{fs : Funext} + C D F G H I + (V : @NaturalTransformation C D F G) + (U : @NaturalTransformation C D G H) + (T : @NaturalTransformation C D H I) +: (T o U) o V = T o (U o V). +Proof. + path_natural_transformation. + + apply associativity. +Qed. +Definition functor_category `{Funext} (C D : PreCategory) : PreCategory + := @Build_PreCategory (Functor C D) + (@NaturalTransformation C D) + (@compose C D) + (@associativity _ C D). + +Notation "C -> D" := (functor_category C D) : category_scope. + +Definition compose_functor `{Funext} (C D E : PreCategory) : object ((C -> D) -> ((D -> E) -> (C -> E))). + admit. + +Defined. + +Definition pullback_along `{Funext} (C C' D : PreCategory) (p : Functor C C') +: object ((C' -> D) -> (C -> D)) + := Eval hnf in compose_functor _ _ _ p. + +Definition IsColimit `{Funext} C D (F : Functor D C) + (x : object + (@comma_category (indiscrete_category Unit) + (@functor_category H (indiscrete_category Unit) C) + (@functor_category H D C) + admit + (@pullback_along H D (indiscrete_category Unit) C + admit))) : Type + := admit. + +Generalizable All Variables. +Axiom fs : Funext. + +Section bar. + + Variable D : PreCategory. + + Context `(has_colimits + : forall F : Functor D C, + @IsColimit _ C D F (colimits F)). +(* Error: Unsatisfied constraints: Top.3773 <= Set + (maybe a bugged tactic). *) +End bar. diff --git a/test-suite/bugs/closed/HoTT_coq_067.v b/test-suite/bugs/closed/HoTT_coq_067.v new file mode 100644 index 00000000..ad32a60c --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_067.v @@ -0,0 +1,28 @@ +Set Universe Polymorphism. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Goal forall (A : Type) (P : forall _ : A, Type) (x0 : A) + (p : P x0) (q : @paths (@sigT A P) (@existT A P x0 p) (@existT A P x0 p)), + @paths (@paths (@sigT A P) (@existT A P x0 p) (@existT A P x0 p)) + (@idpath (@sigT A P) (@existT A P x0 p)) + (@idpath (@sigT A P) (@existT A P x0 p)). + intros. + induction q. + admit. +Qed. +(** Error: Illegal application: +The term "paths_rect" of type + "forall (A : Type) (a : A) (P : forall a0 : A, paths a a0 -> Type), + P a (idpath a) -> forall (y : A) (p : paths a y), P y p" +cannot be applied to the terms + "{x : _ & P x}" : "Type" + "s" : "{x : _ & P x}" + "fun (a : {x : _ & P x}) (_ : paths s a) => paths (idpath a) (idpath a)" + : "forall a : {x : _ & P x}, paths s a -> Type" + "match proof_admitted return (paths (idpath s) (idpath s)) with + end" : "paths (idpath s) (idpath s)" + "s" : "{x : _ & P x}" + "q" : "paths (existT P x0 p) (existT P x0 p)" +The 3rd term has type "forall a : {x : _ & P x}, paths s a -> Type" +which should be coercible to "forall a : {x : _ & P x}, paths s a -> Type". *) diff --git a/test-suite/bugs/closed/HoTT_coq_068.v b/test-suite/bugs/closed/HoTT_coq_068.v new file mode 100644 index 00000000..f1cdcbf2 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_068.v @@ -0,0 +1,61 @@ +Generalizable All Variables. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Module success. + Axiom bar : nat -> Type -> Type. + + Definition foo (n : nat) (A : Type) : Type := + match n with + | O => A + | S n' => forall x y : A, bar n' (x = y) + end. + + Definition foo_succ n A : foo (S n) A. + Admitted. + + Goal forall n (X Y : Type) (y : X) (x : X), bar n (x = y). + intros. + apply (foo_succ _ _). + Defined. +End success. + +Module failure. + Fixpoint bar (n : nat) (A : Type) : Type := + match n with + | O => A + | S n' => forall x y : A, bar n' (x = y) + end. + + Definition foo_succ n A : bar (S n) A. + Admitted. + + Goal forall n (X Y : Type) (y : X) (x : X), bar n (x = y). + intros. + apply foo_succ. + (* Toplevel input, characters 22-34: +Error: In environment +n : nat +X : Type +Y : Type +y : X +x : X +Unable to unify + "forall x0 y0 : ?16, + (fix bar (n : nat) (A : Type) {struct n} : Type := + match n with + | 0 => A + | S n' => forall x y : A, bar n' (x = y) + end) ?15 (x0 = y0)" with + "(fix bar (n : nat) (A : Type) {struct n} : Type := + match n with + | 0 => A + | S n' => forall x y : A, bar n' (x = y) + end) n (x = y)". +*) + Defined. +End failure. diff --git a/test-suite/bugs/closed/HoTT_coq_071.v b/test-suite/bugs/closed/HoTT_coq_071.v new file mode 100644 index 00000000..b5a5ec1b --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_071.v @@ -0,0 +1,9 @@ +Set Universe Polymorphism. +Definition foo : True. + abstract exact I. +Defined. +Eval hnf in foo. (* Should not be [I] *) +Goal True. +Proof. + Fail unify foo I. +Abort. diff --git a/test-suite/bugs/closed/HoTT_coq_074.v b/test-suite/bugs/closed/HoTT_coq_074.v new file mode 100644 index 00000000..370c7d40 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_074.v @@ -0,0 +1,10 @@ +Monomorphic Definition U1 := Type. +Monomorphic Definition U2 := Type. + +Set Printing Universes. +Definition foo : True. +let t1 := type of U1 in +let t2 := type of U2 in +idtac t1 t2; +pose (t1 : t2). exact I. +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_077.v b/test-suite/bugs/closed/HoTT_coq_077.v new file mode 100644 index 00000000..db3b60ed --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_077.v @@ -0,0 +1,39 @@ +Set Implicit Arguments. + +Require Import Logic. + +Set Asymmetric Patterns. +Set Record Elimination Schemes. +Set Primitive Projections. + +Record prod (A B : Type) : Type := + pair { fst : A; snd : B }. + +Print prod_rect. +(** prod_rect = +fun (A B : Type) (P : prod A B -> Type) + (f : forall (fst : A) (snd : B), P {| fst := fst; snd := snd |}) + (p : prod A B) => +match p as p0 return (P p0) with +| {| fst := x; snd := x0 |} => f x x0 +end + : forall (A B : Type) (P : prod A B -> Type), + (forall (fst : A) (snd : B), P {| fst := fst; snd := snd |}) -> + forall p : prod A B, P p + +Arguments A, B are implicit +Argument scopes are [type_scope type_scope _ _ _] + *) + +(* What I really want: *) +Definition prod_rect' A B (P : prod A B -> Type) (u : forall (fst : A) (snd : B), P (pair fst snd)) + (p : prod A B) : P p + := u (fst p) (snd p). + +Notation typeof x := ($(let T := type of x in exact T)$) (only parsing). + +(* Check for eta *) +Check eq_refl : typeof (@prod_rect) = typeof (@prod_rect'). + +(* Check for the recursion principle I want *) +Check eq_refl : @prod_rect = @prod_rect'. diff --git a/test-suite/bugs/closed/HoTT_coq_078.v b/test-suite/bugs/closed/HoTT_coq_078.v new file mode 100644 index 00000000..54cb68b0 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_078.v @@ -0,0 +1,43 @@ +Set Implicit Arguments. +Require Import Logic. + +(*Global Set Universe Polymorphism.*) +Global Set Asymmetric Patterns. +Local Set Primitive Projections. + +Local Open Scope type_scope. + +Record prod (A B : Type) : Type := + pair { fst : A; snd : B }. + +Arguments pair {A B} _ _. + +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. + +Generalizable Variables X A B f g n. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition transport_prod' {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a') + (z : P a * Q a) + : transport (fun a => P a * Q a) p z = (transport _ p (fst z), transport _ p (snd z)) + := match p as p' return transport (fun a0 => P a0 * Q a0) p' z = (transport P p' (fst z), transport Q p' (snd z)) with + | idpath => idpath + end. (* success *) + +Definition transport_prod {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a') + (z : P a * Q a) + : transport (fun a => P a * Q a) p z = (transport _ p (fst z), transport _ p (snd z)) + := match p with + | idpath => idpath + end. diff --git a/test-suite/bugs/closed/HoTT_coq_079.v b/test-suite/bugs/closed/HoTT_coq_079.v new file mode 100644 index 00000000..e70de9ca --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_079.v @@ -0,0 +1,16 @@ +Set Primitive Projections. +Set Implicit Arguments. +Set Universe Polymorphism. + +Inductive paths A (x : A) : A -> Type := idpath : paths x x. + +Notation "x = y :> A" := (@paths A x y). +Notation "x = y" := (x = y :> _). + +Record foo := { x : Type; H : x = x }. + +Create HintDb bar discriminated. +Hint Resolve H : bar. +Goal forall y : foo, @x y = @x y. +intro y. +progress auto with bar. (* failed to progress *) diff --git a/test-suite/bugs/closed/HoTT_coq_080.v b/test-suite/bugs/closed/HoTT_coq_080.v new file mode 100644 index 00000000..6b07c304 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_080.v @@ -0,0 +1,27 @@ +Set Primitive Projections. +Set Implicit Arguments. +Set Universe Polymorphism. +Set Asymmetric Patterns. +Set Printing Projections. +Inductive sum A B := inl : A -> sum A B | inr : B -> sum A B. +Inductive Empty :=. + +Record category := + { ob :> Type; + hom : ob -> ob -> Type + }. + +Definition sum_category (C D : category) : category := + {| + ob := sum (ob C) (ob D); + hom x y := match x, y with + | inl x, inl y => @hom C x y + | inr x, inr y => @hom D x y + | _, _ => Empty + end |}. + +Goal forall C D (x y : ob (sum_category C D)), Type. +intros C D x y. +hnf in x, y. +exact (hom (sum_category _ _) x y). +Defined. \ No newline at end of file diff --git a/test-suite/bugs/closed/HoTT_coq_081.v b/test-suite/bugs/closed/HoTT_coq_081.v new file mode 100644 index 00000000..ac27dea7 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_081.v @@ -0,0 +1,16 @@ +Set Primitive Projections. +Set Implicit Arguments. +Set Universe Polymorphism. + +Record category (A : Type) := + { ob :> Type; + hom : ob -> ob -> Type + }. + +Record foo { A: Type } := { C : category A; x : ob C; y :> hom _ x x }. +Definition comp A (C : category A) (x : C) (f : hom _ x x) := f. + +Definition bar A (f : @foo A) := @comp _ _ _ f. + +(* Toplevel input, characters 0-42: +Error: Cannot find the target class. *) diff --git a/test-suite/bugs/closed/HoTT_coq_082.v b/test-suite/bugs/closed/HoTT_coq_082.v new file mode 100644 index 00000000..ccba22ca --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_082.v @@ -0,0 +1,19 @@ +Set Implicit Arguments. +Set Universe Polymorphism. + +Record category := + { ob : Type }. + +Existing Class category. (* +Toplevel input, characters 0-24: +Anomaly: Mismatched instance and context when building universe substitution. +Please report. *) + +Record category' := + { ob' : Type; + hom' : ob' -> ob' -> Type }. + +Existing Class category'. (* +Toplevel input, characters 0-24: +Anomaly: Mismatched instance and context when building universe substitution. +Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_083.v b/test-suite/bugs/closed/HoTT_coq_083.v new file mode 100644 index 00000000..494b25c7 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_083.v @@ -0,0 +1,29 @@ +Set Primitive Projections. +Set Implicit Arguments. +Set Universe Polymorphism. + +Record category := + { ob : Type }. + +Goal forall C, ob C -> ob C. +intros. +generalize dependent (ob C). +(* 1 subgoals, subgoal 1 (ID 7) + + C : category + ============================ + forall T : Type, T -> T +(dependent evars:) *) +intros T t. +Undo 2. +generalize dependent (@ob C). +(* 1 subgoals, subgoal 1 (ID 6) + + C : category + X : ob C + ============================ + Type -> ob C +(dependent evars:) *) +intros T t. +(* Toplevel input, characters 9-10: +Error: No product even after head-reduction. *) diff --git a/test-suite/bugs/closed/HoTT_coq_084.v b/test-suite/bugs/closed/HoTT_coq_084.v new file mode 100644 index 00000000..d007e4e2 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_084.v @@ -0,0 +1,49 @@ +Set Implicit Arguments. +Set Universe Polymorphism. + +Module success. + Unset Primitive Projections. + + Record group := + { carrier : Type; + id : carrier }. + + Notation "1" := (id _) : g_scope. + + Delimit Scope g_scope with g. + Bind Scope g_scope with carrier. + + Section foo. + Variable g : group. + Variable comp : carrier g -> carrier g -> carrier g. + + Check comp 1 1. + End foo. +End success. + +Module failure. + Set Primitive Projections. + + Record group := + { carrier : Type; + id : carrier }. + + Notation "1" := (id _) : g_scope. + + Delimit Scope g_scope with g. + Bind Scope g_scope with carrier. + + Section foo. + Variable g : group. + Variable comp : carrier g -> carrier g -> carrier g. + + Check comp 1 1. + (* Toplevel input, characters 11-12: +Error: +In environment +g : group +comp : carrier g -> carrier g -> carrier g +The term "1" has type "nat" while it is expected to have type "carrier g". + *) + End foo. +End failure. diff --git a/test-suite/bugs/closed/HoTT_coq_085.v b/test-suite/bugs/closed/HoTT_coq_085.v new file mode 100644 index 00000000..041c6799 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_085.v @@ -0,0 +1,74 @@ +Set Implicit Arguments. +Set Universe Polymorphism. + +Module success. + Unset Primitive Projections. + + Record category := + { ob : Type; + hom : ob -> ob -> Type; + comp : forall x y z, hom y z -> hom x y -> hom x z }. + + Delimit Scope hom_scope with hom. + Bind Scope hom_scope with hom. + Arguments hom : clear implicits. + Arguments comp _ _ _ _ _%hom _%hom : clear implicits. + + Notation "f 'o' g" := (comp _ _ _ _ f g) (at level 40, left associativity) : hom_scope. + + Record functor (C D : category) := + { ob_of : ob C -> ob D; + hom_of : forall x y, hom C x y -> hom D (ob_of x) (ob_of y) }. + + Delimit Scope functor_scope with functor. + Bind Scope functor_scope with functor. + + Arguments hom_of _ _ _%functor _ _ _%hom. + + Notation "F '_1' m" := (hom_of F _ _ m) (at level 10, no associativity) : hom_scope. + + Axiom f_comp : forall C D E, functor D E -> functor C D -> functor C E. + Notation "f 'o' g" := (@f_comp _ _ _ f g) (at level 40, left associativity) : functor_scope. + + Check ((_ o _) _1 _)%hom. (* ((?16 o ?17) _1 ?20)%hom + : hom ?15 (ob_of (?16 o ?17) ?18) (ob_of (?16 o ?17) ?19) *) +End success. + +Module failure. + Set Primitive Projections. + + Record category := + { ob : Type; + hom : ob -> ob -> Type; + comp : forall x y z, hom y z -> hom x y -> hom x z }. + + Delimit Scope hom_scope with hom. + Bind Scope hom_scope with hom. + Arguments hom : clear implicits. + Arguments comp _ _ _ _ _%hom _%hom : clear implicits. + + Notation "f 'o' g" := (comp _ _ _ _ f g) (at level 40, left associativity) : hom_scope. + + Record functor (C D : category) := + { ob_of : ob C -> ob D; + hom_of : forall x y, hom C x y -> hom D (ob_of x) (ob_of y) }. + + Delimit Scope functor_scope with functor. + Bind Scope functor_scope with functor. + + Arguments hom_of _ _ _%functor _ _ _%hom. + + Notation "F '_1' m" := (hom_of F _ _ m) (at level 10, no associativity) : hom_scope. + Notation "F '_2' m" := (hom_of F%functor _ _ m) (at level 10, no associativity) : hom_scope. + + Axiom f_comp : forall C D E, functor D E -> functor C D -> functor C E. + Notation "f 'o' g" := (@f_comp _ _ _ f g) (at level 40, left associativity) : functor_scope. + + Check ((_ o _) _2 _)%hom. (* ((?14 o ?15)%functor _1 ?18)%hom + : hom ?13 (ob_of (?14 o ?15)%functor ?16) + (ob_of (?14 o ?15)%functor ?17) *) + Check ((_ o _) _1 _)%hom. (* Toplevel input, characters 7-19: +Error: +The term "(?23 o ?24)%hom" has type "hom ?19 ?20 ?22" +while it is expected to have type "functor ?25 ?26". *) +End failure. diff --git a/test-suite/bugs/closed/HoTT_coq_087.v b/test-suite/bugs/closed/HoTT_coq_087.v new file mode 100644 index 00000000..265310b1 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_087.v @@ -0,0 +1,14 @@ +Structure type : Type := Pack { ob : Type }. +Polymorphic Record category := { foo : Type }. +Definition FuncComp := Pack category. +Axiom C : category. + +Check (C : ob FuncComp). (* OK *) + +Canonical Structure FuncComp. + +Check (C : ob FuncComp). +(* Toplevel input, characters 15-39: +Error: +The term "C" has type "category" while it is expected to have type + "ob FuncComp". *) diff --git a/test-suite/bugs/closed/HoTT_coq_088.v b/test-suite/bugs/closed/HoTT_coq_088.v new file mode 100644 index 00000000..b3e1df57 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_088.v @@ -0,0 +1,78 @@ +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Arguments paths_ind [A] a P f y p. +Arguments paths_rec [A] a P f y p. +Arguments paths_rect [A] a P f y p. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +(** A typeclass that includes the data making [f] into an adjoint equivalence. *) +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Record Equiv A B := BuildEquiv { + equiv_fun :> A -> B ; + equiv_isequiv :> IsEquiv equiv_fun +}. + + +Definition equiv_path (A B : Type) (p : A = B) : Equiv A B. +Admitted. + +Class Univalence := { + isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B) +}. + +Definition ua_downward_closed `{Univalence} : Univalence. + constructor. + intros A B. + destruct H as [H]. + generalize (fun A B => @eisretr _ _ _ (H (A : Type) (B : Type))). + generalize (fun A B => @eissect _ _ _ (H (A : Type) (B : Type))). + let g := match goal with |- _ -> _ -> ?g => constr:(g) end in + let U0 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U0) end in + let U1 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U1) end in + let U2 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U2) end in + let U3 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U3) end in + let f0 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(f) end in + let f' := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(f') end in + change ((forall (A : U0) (B : U1), Sect (f0 A B) ((fun (A : U0) (B : U1) => @equiv_inv _ _ _ (H A B)) A B)) + -> (forall (A : U2) (B : U3), Sect ((fun (A : U0) (B : U1) => @equiv_inv _ _ _ (H A B)) A B) (f' A B)) + -> g); + generalize (fun (A : U0) (B : U1) => @equiv_inv _ _ _ (H A B)); + clear H; + simpl; + intros fi sect retr. + pose proof fi as fi'. + Set Printing All. + change (forall (A : Type) (B : Type) (_ : Equiv A B), @paths Type A B) in fi'. + (*refine (@isequiv_adjointify + _ _ + _ _ + _ + _); + admit. + Grab Existential Variables.*) + admit. + (*destruct p.*) + (*specialize (H (A' : Type)).*) +Defined. +(* Error: Unsatisfied constraints: +Top.62 < Top.61 +Top.64 <= Top.62 +Top.63 <= Top.62 + (maybe a bugged tactic).*) diff --git a/test-suite/bugs/closed/HoTT_coq_089.v b/test-suite/bugs/closed/HoTT_coq_089.v new file mode 100644 index 00000000..2da4aff6 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_089.v @@ -0,0 +1,44 @@ +Set Implicit Arguments. +Set Universe Polymorphism. +Set Printing Universes. + +Inductive type_paths (A : Type) : Type -> Prop + := idtypepath : type_paths A A. +Monomorphic Definition comp_type_paths := Eval compute in type_paths@{Type Type}. +Check comp_type_paths. +(* comp_type_paths + : Type (* Top.12 *) -> Type (* Top.12 *) -> Prop *) +(* This is terrible. *) + +Inductive type_paths' (A : Type) : Type -> Prop + := idtypepath' : type_paths' A A + | other_type_path : False -> forall B : Type, type_paths' A B. +Monomorphic Definition comp_type_paths' := Eval compute in type_paths'. +Check comp_type_paths'. +(* comp_type_paths' + : Type (* Top.24 *) -> Type (* Top.23 *) -> Prop *) +(* Ok, then ... *) + +(** Fail if it's [U0 -> U0 -> _], but not on [U0 -> U1 -> _]. *) +Goal Type. +Proof. + match type of comp_type_paths' with + | ?U0 -> ?U1 -> ?R + => exact (@comp_type_paths' nat U0) + end. +Defined. + +Goal Type. +Proof. + match type of comp_type_paths with + | ?U0 -> ?U1 -> ?R + => exact (@comp_type_paths nat U0) + end. + (* Toplevel input, characters 110-112: +Error: +The term "Type (* Top.51 *)" has type "Type (* Top.51+1 *)" +while it is expected to have type "Type (* Top.51 *)" +(Universe inconsistency: Cannot enforce Top.51 < Top.51 because Top.51 += Top.51)). *) + +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_090.v b/test-suite/bugs/closed/HoTT_coq_090.v new file mode 100644 index 00000000..5c704147 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_090.v @@ -0,0 +1,187 @@ +(** I'm not sure if this tests what I want it to test... *) +Set Implicit Arguments. +Set Universe Polymorphism. + +Notation idmap := (fun x => x). + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Arguments paths_ind [A] a P f y p. +Arguments paths_rec [A] a P f y p. +Arguments paths_rect [A] a P f y p. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +(** A typeclass that includes the data making [f] into an adjoint equivalence. *) +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Arguments eisretr {A B} f {_} _. +Arguments eissect {A B} f {_} _. +Arguments eisadj {A B} f {_} _. + + +Record Equiv A B := BuildEquiv { + equiv_fun :> A -> B ; + equiv_isequiv :> IsEquiv equiv_fun +}. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. + +(** See above for the meaning of [simpl nomatch]. *) +Arguments concat {A x y z} p q : simpl nomatch. + +(** The inverse of a path. *) +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +(** Declaring this as [simpl nomatch] prevents the tactic [simpl] from expanding it out into [match] statements. We only want [inverse] to simplify when applied to an identity path. *) +Arguments inverse {A x y} p : simpl nomatch. + +(** Note that you can use the built-in Coq tactics [reflexivity] and [transitivity] when working with paths, but not [symmetry], because it is too smart for its own good. Instead, you can write [apply symmetry] or [eapply symmetry]. *) + +(** The identity path. *) +Notation "1" := idpath : path_scope. + +(** The composition of two paths. *) +Notation "p @ q" := (concat p q) (at level 20) : path_scope. + +(** The inverse of a path. *) +Notation "p ^" := (inverse p) (at level 3) : path_scope. + +(** An alternative notation which puts each path on its own line. Useful as a temporary device during proofs of equalities between very long composites; to turn it on inside a section, say [Open Scope long_path_scope]. *) +Notation "p @' q" := (concat p q) (at level 21, left associativity, + format "'[v' p '/' '@'' q ']'") : long_path_scope. + + +(** An important instance of [paths_rect] is that given any dependent type, one can _transport_ elements of instances of the type along equalities in the base. + + [transport P p u] transports [u : P x] to [P y] along [p : x = y]. *) +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +(** See above for the meaning of [simpl nomatch]. *) +Arguments transport {A} P {x y} p%path_scope u : simpl nomatch. + + + +Instance isequiv_path {A B : Type} (p : A = B) + : IsEquiv (transport (fun X:Type => X) p) | 0. +Proof. + refine (@BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) _ _ _); + admit. +Defined. + +Definition equiv_path (A B : Type) (p : A = B) : Equiv A B + := @BuildEquiv _ _ (transport (fun X:Type => X) p) _. + +Arguments equiv_path : clear implicits. + +Definition equiv_adjointify A B (f : A -> B) (g : B -> A) (r : Sect g f) (s : Sect f g) : Equiv A B. +Proof. + refine (@BuildEquiv A B f (@BuildIsEquiv A B f g r s _)). + admit. +Defined. + + +Set Printing Universes. + +Definition lift_id_type : Type. +Proof. + let U0 := constr:(Type) in + let U1 := constr:(Type) in + let unif := constr:(U0 : U1) in + exact (forall (A : Type) (B : Type), @paths U0 A B -> @paths U1 A B). +Defined. + +Definition lower_id_type : Type. +Proof. + let U0 := constr:(Type) in + let U1 := constr:(Type) in + let unif := constr:(U0 : U1) in + exact ((forall (A : Type) (B : Type), IsEquiv (equiv_path (A : U0) (B : U0))) + -> forall (A : Type) (B : Type), @paths U1 A B -> @paths U0 A B). +Defined. + +Definition lift_id : lift_id_type := + fun A B p => match p in @paths _ _ B return @paths Type (A : Type) (B : Type) with + | idpath => idpath + end. + +Definition lower_id : lower_id_type. +Proof. + intros ua A B p. + specialize (ua A B). + apply (@equiv_inv _ _ (equiv_path A B) _). + simpl. + pose (f := transport idmap p : A -> B). + pose (g := transport idmap p^ : B -> A). + refine (@equiv_adjointify + _ _ + f g + _ _); + subst f g; unfold transport, inverse; + clear ua; + [ intro x + | exact match p as p in (_ = B) return + (forall x : (A : Type), + @paths (* Top.904 *) + A + match + match + p in (paths _ a) + return (@paths (* Top.906 *) Type (* Top.900 *) a A) + with + | idpath => @idpath (* Top.906 *) Type (* Top.900 *) A + end in (paths _ a) return a + with + | idpath => match p in (paths _ a) return a with + | idpath => x + end + end x) + with + | idpath => fun _ => idpath + end ]. + + - pose proof (match p as p in (_ = B) return + (forall x : (B : Type), + match p in (_ = a) return (a : Type) with + | idpath => + match + match p in (_ = a) return (@paths Type (a : Type) (A : Type)) with + | idpath => idpath + end in (_ = a) return (a : Type) + with + | idpath => x + end + end = x) + with + | idpath => fun _ => idpath + end x) as p'. + admit. +Defined. +(* Error: Illegal application: +The term "paths (* Top.96 *)" of type + "forall A : Type (* Top.96 *), A -> A -> Type (* Top.96 *)" +cannot be applied to the terms + "Type (* Top.100 *)" : "Type (* Top.100+1 *)" + "a" : "Type (* Top.60 *)" + "A" : "Type (* Top.57 *)" +The 2nd term has type "Type (* Top.60 *)" which should be coercible to + "Type (* Top.100 *)". + *) diff --git a/test-suite/bugs/closed/HoTT_coq_091.v b/test-suite/bugs/closed/HoTT_coq_091.v new file mode 100644 index 00000000..1e4497e7 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_091.v @@ -0,0 +1,191 @@ +Set Implicit Arguments. + +Set Printing Universes. + +Set Asymmetric Patterns. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Arguments paths_ind [A] a P f y p. +Arguments paths_rec [A] a P f y p. +Arguments paths_rect [A] a P f y p. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. +Arguments ap {A B} f {x y} p : simpl nomatch. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +(** A typeclass that includes the data making [f] into an adjoint equivalence. *) +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Arguments eisretr {A B} f {_} _. +Arguments eissect {A B} f {_} _. +Arguments eisadj {A B} f {_} _. + + +Inductive type_eq (A : Type) : Type -> Type := +| type_eq_refl : type_eq A A +| type_eq_impossible : False -> forall B : Type, type_eq A B. + +Definition type_eq_sym {A B} (p : type_eq A B) : type_eq B A + := match p in (type_eq _ B) return (type_eq B A) with + | type_eq_refl => type_eq_refl _ + | type_eq_impossible f B => type_eq_impossible _ f A + end. + +Definition type_eq_sym_type_eq_sym {A B} (p : type_eq A B) : type_eq_sym (type_eq_sym p) = p + := match p as p return type_eq_sym (type_eq_sym p) = p with + | type_eq_refl => idpath + | type_eq_impossible f _ => idpath + end. + +Module Type LiftT. + Section local. + Let type_cast_up_type : Type. + Proof. + let U0 := constr:(Type) in + let U1 := constr:(Type) in + let unif := constr:(U0 : U1) in + exact (forall T : U0, { T' : U1 & type_eq T' T }). + Defined. + + Axiom type_cast_up : type_cast_up_type. + End local. + + Definition Lift (T : Type) := projT1 (type_cast_up T). + Definition lift {T} : T -> Lift T + := match projT2 (type_cast_up T) in (type_eq _ T') return T' -> Lift T with + | type_eq_refl => fun x => x + | type_eq_impossible bad _ => match bad with end + end. + Section equiv. + Definition lower' {T} : Lift T -> T + := match projT2 (type_cast_up T) in (type_eq _ T') return Lift T -> T' with + | type_eq_refl => fun x => x + | type_eq_impossible bad _ => match bad with end + end. + Definition lift_lower {T} (x : Lift T) : lift (lower' x) = x. + Proof. + unfold lower', lift. + destruct (projT2 (type_cast_up T)) as [|[]]. + reflexivity. + Defined. + Definition lower_lift {T} (x : T) : lower' (lift x) = x. + Proof. + unfold lower', lift, Lift in *. + destruct (type_cast_up T) as [T' p]; simpl. + let y := match goal with |- ?y => constr:(y) end in + let P := match (eval pattern p in y) with ?f p => constr:(f) end in + apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *. + generalize (type_eq_sym p); intro p'; clear p. + destruct p' as [|[]]; simpl. + reflexivity. + Defined. + + Global Instance isequiv_lift A : IsEquiv (@lift A). + Proof. + refine (@BuildIsEquiv + _ _ + lift lower' + lift_lower + lower_lift + _). + compute. + intro x. + destruct (type_cast_up A) as [T' p]. + let y := match goal with |- ?y => constr:(y) end in + let P := match (eval pattern p in y) with ?f p => constr:(f) end in + apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *. + generalize (type_eq_sym p); intro p'; clear p. + destruct p' as [|[]]; simpl. + reflexivity. + Defined. + End equiv. + Definition lower {A} := (@equiv_inv _ _ (@lift A) _). +End LiftT. + +Module Lift : LiftT. + Section local. + Let type_cast_up_type : Type. + Proof. + let U0 := constr:(Type) in + let U1 := constr:(Type) in + let unif := constr:(U0 : U1) in + exact (forall T : U0, { T' : U1 & type_eq T' T }). + Defined. + + Definition type_cast_up : type_cast_up_type + := fun T => existT (fun T' => type_eq T' T) T (type_eq_refl _). + End local. + + Definition Lift (T : Type) := projT1 (type_cast_up T). + Definition lift {T} : T -> Lift T + := match projT2 (type_cast_up T) in (type_eq _ T') return T' -> Lift T with + | type_eq_refl => fun x => x + | type_eq_impossible bad _ => match bad with end + end. + Section equiv. + Definition lower' {T} : Lift T -> T + := match projT2 (type_cast_up T) in (type_eq _ T') return Lift T -> T' with + | type_eq_refl => fun x => x + | type_eq_impossible bad _ => match bad with end + end. + Definition lift_lower {T} (x : Lift T) : lift (lower' x) = x. + Proof. + unfold lower', lift. + destruct (projT2 (type_cast_up T)) as [|[]]. + reflexivity. + Defined. + Definition lower_lift {T} (x : T) : lower' (lift x) = x. + Proof. + unfold lower', lift, Lift in *. + destruct (type_cast_up T) as [T' p]; simpl. + let y := match goal with |- ?y => constr:(y) end in + let P := match (eval pattern p in y) with ?f p => constr:(f) end in + apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *. + generalize (type_eq_sym p); intro p'; clear p. + destruct p' as [|[]]; simpl. + reflexivity. + Defined. + + + Global Instance isequiv_lift A : IsEquiv (@lift A). + Proof. + refine (@BuildIsEquiv + _ _ + lift lower' + lift_lower + lower_lift + _). + compute. + intro x. + destruct (type_cast_up A) as [T' p]. + let y := match goal with |- ?y => constr:(y) end in + let P := match (eval pattern p in y) with ?f p => constr:(f) end in + apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *. + generalize (type_eq_sym p); intro p'; clear p. + destruct p' as [|[]]; simpl. + reflexivity. + Defined. + End equiv. + Definition lower {A} := (@equiv_inv _ _ (@lift A) _). +End Lift. +(* Toplevel input, characters 15-24: +Anomaly: Invalid argument: enforce_eq_instances called with instances of different lengths. +Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_093.v b/test-suite/bugs/closed/HoTT_coq_093.v new file mode 100644 index 00000000..38943ab3 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_093.v @@ -0,0 +1,27 @@ +(** It would be nice if we had more lax constraint checking of inductive types, and had variance annotations on their universes *) +Set Printing All. +Set Printing Implicit. +Set Printing Universes. +Set Universe Polymorphism. + +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Arguments idpath {A a} , [A] a. + +Notation "x = y" := (@paths _ x y) : type_scope. + +Section lift. + Let lift_type : Type. + Proof. + let U0 := constr:(Type) in + let U1 := constr:(Type) in + let unif := constr:(U0 : U1) in + exact (U0 -> U1). + Defined. + + Definition Lift (A : Type@{i}) : Type@{j} := A. +End lift. + +Goal forall (A : Type@{i}) (x y : A), @paths@{i} A x y -> @paths@{j} A x y. +intros A x y p. +compute in *. destruct p. exact idpath. +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_094.v b/test-suite/bugs/closed/HoTT_coq_094.v new file mode 100644 index 00000000..13e0605d --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_094.v @@ -0,0 +1,9 @@ +Record PreCategory := Build_PreCategory' { object :> Type }. +Class Foo (X : Type) := {}. +Class Bar := {}. +Definition functor_category `{Bar} (C D : PreCategory) `{Foo (object D)} : PreCategory. +Admitted. +Fail Definition functor_object_of `{Bar} (C1 C2 D : PreCategory) `{Foo (object D)} +: functor_category C1 (functor_category C2 D) -> True. +(** Anomaly: File "toplevel/himsg.ml", line ..., characters ...: Assertion failed. +Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_097.v b/test-suite/bugs/closed/HoTT_coq_097.v new file mode 100644 index 00000000..38e8007b --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_097.v @@ -0,0 +1,5 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +Set Universe Polymorphism. +Set Printing Universes. +Inductive Empty : Set := . +(* Error: Universe inconsistency. Cannot enforce Prop <= Set). *) diff --git a/test-suite/bugs/closed/HoTT_coq_098.v b/test-suite/bugs/closed/HoTT_coq_098.v new file mode 100644 index 00000000..fc99daab --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_098.v @@ -0,0 +1,63 @@ +Set Implicit Arguments. +Generalizable All Variables. + +Polymorphic Record SpecializedCategory (obj : Type) := Build_SpecializedCategory' { + Object :> _ := obj; + Morphism' : obj -> obj -> Type; + + Identity' : forall o, Morphism' o o; + Compose' : forall s d d', Morphism' d d' -> Morphism' s d -> Morphism' s d' +}. + +Polymorphic Definition TypeCat : @SpecializedCategory Type + := (@Build_SpecializedCategory' Type + (fun s d => s -> d) + (fun _ => (fun x => x)) + (fun _ _ _ f g => (fun x => f (g x)))). + +Inductive GraphIndex := GraphIndexSource | GraphIndexTarget. +Polymorphic Definition GraphIndexingCategory : @SpecializedCategory GraphIndex. +Admitted. + +Module success. + Section SpecializedFunctor. + Set Universe Polymorphism. + Context `(C : @SpecializedCategory objC). + Context `(D : @SpecializedCategory objD). + Unset Universe Polymorphism. + + Polymorphic Record SpecializedFunctor + := { + ObjectOf' : objC -> objD; + MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d) + }. + End SpecializedFunctor. + + Polymorphic Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat. + Admitted. +End success. + +Module success2. + Section SpecializedFunctor. + Polymorphic Context `(C : @SpecializedCategory objC). + Polymorphic Context `(D : @SpecializedCategory objD). + + Polymorphic Record SpecializedFunctor + := { + ObjectOf' : objC -> objD; + MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d) + }. + End SpecializedFunctor. + + Set Printing Universes. + Polymorphic Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat. + (* Toplevel input, characters 73-94: +Error: +The term "GraphIndexingCategory (* Top.563 *)" has type + "SpecializedCategory (* Top.563 Set *) GraphIndex" +while it is expected to have type + "SpecializedCategory (* Top.550 Top.551 *) ?7" +(Universe inconsistency: Cannot enforce Set = Top.551)). *) + admit. + Defined. +End success2. diff --git a/test-suite/bugs/closed/HoTT_coq_099.v b/test-suite/bugs/closed/HoTT_coq_099.v new file mode 100644 index 00000000..9b6ace82 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_099.v @@ -0,0 +1,61 @@ +(* File reduced by coq-bug-finder from 138 lines to 78 lines. *) +Set Implicit Arguments. +Generalizable All Variables. +Set Universe Polymorphism. +Delimit Scope object_scope with object. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Record Category (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Identity : forall x, Morphism x x; + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Arguments Identity {obj%type} [!C%category] x%object : rename. +Arguments Compose {obj%type} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. +Bind Scope category_scope with Category. + +Record Functor `(C : @Category objC) `(D : @Category objD) + := { ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) }. + +Record NaturalTransformation `(C : @Category objC) `(D : @Category objD) (F G : Functor C D) + := { ComponentsOf :> forall c, D.(Morphism) (F c) (G c) }. + +Definition ProductCategory `(C : @Category objC) `(D : @Category objD) +: @Category (objC * objD)%type + := @Build_Category _ + (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type) + (fun o => (Identity (fst o), Identity (snd o))) + (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1))). + +Infix "*" := ProductCategory : category_scope. + +Record IsomorphismOf `{C : @Category objC} {s d} (m : C.(Morphism) s d) := + { IsomorphismOf_Morphism :> C.(Morphism) s d := m; + Inverse : C.(Morphism) d s }. + +Record NaturalIsomorphism `(C : @Category objC) `(D : @Category objD) (F G : Functor C D) + := { NaturalIsomorphism_Transformation :> NaturalTransformation F G; + NaturalIsomorphism_Isomorphism : forall x : objC, IsomorphismOf (NaturalIsomorphism_Transformation x) }. + +Section PreMonoidalCategory. + Context `(C : @Category objC). + Definition TriMonoidalProductL : Functor (C * C * C) C. + admit. + Defined. + Definition TriMonoidalProductR : Functor (C * C * C) C. + admit. + Defined. (** Replacing [admit. Defined.] with [Admitted.] satisfies the constraints *) + Variable Associator : NaturalIsomorphism TriMonoidalProductL TriMonoidalProductR. + (* Toplevel input, characters 15-96: +Error: Unsatisfied constraints: +Coq.Init.Datatypes.28 <= Coq.Init.Datatypes.29 +Top.168 <= Coq.Init.Datatypes.29 +Top.168 <= Coq.Init.Datatypes.28 +Top.169 <= Coq.Init.Datatypes.29 +Top.169 <= Coq.Init.Datatypes.28 + (maybe a bugged tactic). *) diff --git a/test-suite/bugs/closed/HoTT_coq_100.v b/test-suite/bugs/closed/HoTT_coq_100.v new file mode 100644 index 00000000..c39b7093 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_100.v @@ -0,0 +1,151 @@ +(* File reduced by coq-bug-finder from 335 lines to 115 lines. *) +Set Implicit Arguments. +Set Universe Polymorphism. +Generalizable All Variables. +Record Category (obj : Type) := + Build_Category { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Identity : forall x, Morphism x x; + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Arguments Identity {obj%type} [!C] x : rename. + +Arguments Compose {obj%type} [!C s d d'] m1 m2 : rename. +Record > Category' := + { + LSObject : Type; + + LSUnderlyingCategory :> @Category LSObject + }. + +Section Functor. + + Context `(C : @Category objC). + Context `(D : @Category objD). + Record Functor := + { + ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. + +End Functor. +Section FunctorComposition. + + Context `(C : @Category objC). + Context `(D : @Category objD). + Context `(E : @Category objE). + Definition ComposeFunctors (G : Functor D E) (F : Functor C D) : Functor C E. + + Admitted. +End FunctorComposition. +Section IdentityFunctor. + + Context `(C : @Category objC). + Definition IdentityFunctor : Functor C C. + + admit. + Defined. +End IdentityFunctor. +Section ProductCategory. + + Context `(C : @Category objC). + Context `(D : @Category objD). + Definition ProductCategory : @Category (objC * objD)%type. + + refine (@Build_Category _ + (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type) + (fun o => (Identity (fst o), Identity (snd o))) + (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1)))). + Defined. +End ProductCategory. +Parameter TerminalCategory : Category unit. + +Section ComputableCategory. + + Variable I : Type. + Variable Index2Object : I -> Type. + Variable Index2Cat : forall i : I, @Category (@Index2Object i). + Local Coercion Index2Cat : I >-> Category. + + Definition ComputableCategory : @Category I. + + refine (@Build_Category _ + (fun C D : I => Functor C D) + (fun o : I => IdentityFunctor o) + (fun C D E : I => ComposeFunctors (C := C) (D := D) (E := E))). + Defined. +End ComputableCategory. +Definition LocallySmallCat := ComputableCategory _ LSUnderlyingCategory. +Section CommaCategory. + + Context `(A : @Category objA). + Context `(B : @Category objB). + Context `(C : @Category objC). + Variable S : Functor A C. + Variable T : Functor B C. + Record CommaCategory_Object := { CommaCategory_Object_Member :> { ab : objA * objB & C.(Morphism) (S (fst ab)) (T (snd ab)) } }. + +End CommaCategory. +Definition SliceCategory_Functor `(C : @Category objC) (a : C) : Functor TerminalCategory C + := {| ObjectOf := (fun _ => a); + MorphismOf := (fun _ _ _ => Identity a) + |}. + +Definition SliceCategoryOver +: forall (objC : Type) (C : Category objC) (a : C), + Category + (CommaCategory_Object (IdentityFunctor C) + (SliceCategory_Functor C a)). + + admit. +Defined. +Section CommaCategoryProjectionFunctor. + + Context `(A : Category objA). + Context `(B : Category objB). + Let X : LocallySmallCat. + + Proof. + hnf. + pose (@SliceCategoryOver _ LocallySmallCat). + exact (ProductCategory A B). + Set Printing Universes. + Defined. +(* Error: Illegal application: +The term + "CommaCategory_Object (* Top.306 Top.307 Top.305 Top.300 Top.305 Top.306 *)" +of type + "forall (objA : Type (* Top.305 *)) + (A : Category (* Top.306 Top.305 *) objA) (objB : Type (* Top.307 *)) + (B : Category (* Top.300 Top.307 *) objB) (objC : Type (* Top.305 *)) + (C : Category (* Top.306 Top.305 *) objC), + Functor (* Top.306 Top.305 Top.305 Top.306 *) A C -> + Functor (* Top.300 Top.307 Top.305 Top.306 *) B C -> + Type (* max(Top.307, Top.305, Top.306) *)" +cannot be applied to the terms + "Category' (* Top.312 Top.311 *)" : "Type (* max(Top.311+1, Top.312+1) *)" + "LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316 Top.305 *)" + : "Category (* Top.306 Top.305 *) Category' (* Top.312 Top.311 *)" + "unit" : "Set" + "TerminalCategory (* Top.300 *)" : "Category (* Top.300 Set *) unit" + "Category' (* Top.312 Top.311 *)" : "Type (* max(Top.311+1, Top.312+1) *)" + "LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316 Top.305 *)" + : "Category (* Top.306 Top.305 *) Category' (* Top.312 Top.311 *)" + "IdentityFunctor (* Top.299 Top.302 Top.301 Top.305 Top.306 *) + LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 + Top.306 Top.316 Top.305 *)" + : "Functor (* Top.306 Top.305 Top.305 Top.306 *) LocallySmallCat + (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316 + Top.305 *) LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 + Top.314 Top.306 Top.316 Top.305 *)" + "SliceCategory_Functor (* Top.305 Top.306 Top.307 Top.300 *) LocallySmallCat + (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316 + Top.305 *) a" + : "Functor (* Top.300 Top.307 Top.305 Top.306 *) TerminalCategory + (* Top.300 *) LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 + Top.313 Top.314 Top.306 Top.316 Top.305 *)" +The 4th term has type "Category (* Top.300 Set *) unit" +which should be coercible to "Category (* Top.300 Top.307 *) unit". *) diff --git a/test-suite/bugs/closed/HoTT_coq_101.v b/test-suite/bugs/closed/HoTT_coq_101.v new file mode 100644 index 00000000..9c89a6ab --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_101.v @@ -0,0 +1,77 @@ +Set Universe Polymorphism. +Set Implicit Arguments. +Generalizable All Variables. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type + }. + + +Record > Category := + { + CObject : Type; + + UnderlyingCategory :> @SpecializedCategory CObject + }. + +Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) := + { + ObjectOf :> objC -> objD; + MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) + }. + +(* Replacing this with [Definition Functor (C D : Category) := +SpecializedFunctor C D.] gets rid of the universe inconsistency. *) +Section Functor. + Variable C D : Category. + + Definition Functor := SpecializedFunctor C D. +End Functor. + +Record SpecializedNaturalTransformation `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) (F G : SpecializedFunctor C D) := + { + ComponentsOf :> forall c, D.(Morphism) (F c) (G c) + }. + +Definition FunctorProduct' `(F : Functor C D) : SpecializedFunctor C D. +admit. +Defined. + +Definition TypeCat : @SpecializedCategory Type. + admit. +Defined. + + +Definition CovariantHomFunctor `(C : @SpecializedCategory objC) : SpecializedFunctor C TypeCat. + refine (Build_SpecializedFunctor C TypeCat + (fun X : C => C.(Morphism) X X) + _ + ); admit. +Defined. + +Definition FunctorCategory `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) : @SpecializedCategory (SpecializedFunctor C D). + refine (@Build_SpecializedCategory _ + (SpecializedNaturalTransformation (C := C) (D := D))). +Defined. + +Definition Yoneda `(C : @SpecializedCategory objC) : SpecializedFunctor C (FunctorCategory C TypeCat). + match goal with + | [ |- SpecializedFunctor ?C0 ?D0 ] => + refine (Build_SpecializedFunctor C0 D0 + (fun c => CovariantHomFunctor C) + _ + ) + end; + admit. +Defined. + +Section FullyFaithful. + Context `(C : @SpecializedCategory objC). + Let TypeCatC := FunctorCategory C TypeCat. + Let YC := (Yoneda C). + Set Printing Universes. + Check @FunctorProduct' C TypeCatC YC. (* Toplevel input, characters 0-37: +Error: Universe inconsistency. Cannot enforce Top.187 = Top.186 because +Top.186 <= Top.189 < Top.191 <= Top.187). *) diff --git a/test-suite/bugs/closed/HoTT_coq_102.v b/test-suite/bugs/closed/HoTT_coq_102.v new file mode 100644 index 00000000..71becfd2 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_102.v @@ -0,0 +1,29 @@ +(* File reduced by coq-bug-finder from 64 lines to 30 lines. *) +Set Implicit Arguments. +Set Universe Polymorphism. +Generalizable All Variables. +Record SpecializedCategory (obj : Type) := { Object :> _ := obj }. + +Record > Category := + { CObject : Type; + UnderlyingCategory :> @SpecializedCategory CObject }. + +Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) := + { ObjectOf :> objC -> objD }. + +Definition Functor (C D : Category) := SpecializedFunctor C D. + +Parameter TerminalCategory : SpecializedCategory unit. + +Definition focus A (_ : A) := True. + +Definition CommaCategory_Object (A : Category) (S : Functor TerminalCategory A) : Type. + assert (Hf : focus ((S tt) = (S tt))) by constructor. + let C1 := constr:(CObject) in + let C2 := constr:(fun C => @Object (CObject C) C) in + let check := constr:(eq_refl : C1 = C2) in + unify C1 C2. + progress change CObject with (fun C => @Object (CObject C) C) in *. + (* not convertible *) + admit. +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_103.v b/test-suite/bugs/closed/HoTT_coq_103.v new file mode 100644 index 00000000..7ecf7671 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_103.v @@ -0,0 +1,4 @@ +Fail Check (nat : Type) : Set. +(* Error: +The term "nat:Type" has type "Type" while it is expected to have type +"Set" (Universe inconsistency). *) diff --git a/test-suite/bugs/closed/HoTT_coq_104.v b/test-suite/bugs/closed/HoTT_coq_104.v new file mode 100644 index 00000000..5bb7fa8c --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_104.v @@ -0,0 +1,13 @@ +Set Implicit Arguments. + +Require Import Logic. + +Global Set Universe Polymorphism. +Global Set Asymmetric Patterns. +Local Set Record Elimination Schemes. +Local Set Primitive Projections. + +Record prod (A B : Type) : Type := + pair { fst : A; snd : B }. + +Check fun x : prod Set Set => eq_refl : x = pair (fst x) (snd x). diff --git a/test-suite/bugs/closed/HoTT_coq_105.v b/test-suite/bugs/closed/HoTT_coq_105.v new file mode 100644 index 00000000..86001d26 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_105.v @@ -0,0 +1,32 @@ +Set Primitive Projections. +Set Implicit Arguments. +Set Universe Polymorphism. +Set Asymmetric Patterns. + +Inductive sum A B := inl : A -> sum A B | inr : B -> sum A B. +Inductive Empty :=. + +Record category := + { ob :> Type; + hom : ob -> ob -> Type + }. +Set Printing All. +Definition sum_category (C D : category) : category := + {| + ob := sum (ob C) (ob D); + hom x y := match x, y with + | inl x, inl y => @hom _ x y (* Toplevel input, characters 177-178: +Error: +In environment +C : category +D : category +x : sum (ob C) (ob D) +y : sum (ob C) (ob D) +x0 : ob C +y0 : ob C +The term "x0" has type "ob C" while it is expected to have type +"ob ?6" (unable to find a well-typed instantiation for +"?6": cannot unify"Type" and "category"). *) + | inr x, inr y => @hom _ x y + | _, _ => Empty + end |}. diff --git a/test-suite/bugs/closed/HoTT_coq_107.v b/test-suite/bugs/closed/HoTT_coq_107.v new file mode 100644 index 00000000..c3a83627 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_107.v @@ -0,0 +1,106 @@ +(* -*- mode: coq; coq-prog-args: ("-nois" "-emacs") -*- *) +(* File reduced by coq-bug-finder from 4897 lines to 2605 lines, then from 2297 lines to 236 lines, then from 239 lines to 137 lines, then from 118 lines to 67 lines, then from 520 lines to 76 lines. *) +(** Note: The bug here is the same as the #113, that is, HoTT_coq_113.v *) +Require Import Coq.Init.Logic. +Global Set Universe Polymorphism. +Global Set Asymmetric Patterns. +Set Implicit Arguments. + +Inductive sigT (A:Type) (P:A -> Type) : Type := + existT : forall x:A, P x -> sigT P. + +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + +Generalizable All Variables. +Definition admit {T} : T. +Admitted. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. +Class Contr_internal (A : Type) := + BuildContr { + center : A ; + contr : (forall y : A, center = y) + }. + +Arguments center A {_}. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Notation Contr := (IsTrunc minus_two). + +Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances. + +Definition path_contr `{Contr A} (x y : A) : x = y + := admit. + +Definition path_sigma' {A : Type} (P : A -> Type) {x x' : A} {y : P x} {y' : P x'} + (p : x = x') (q : transport _ p y = y') +: existT _ x y = existT _ x' y' + := admit. +Instance trunc_sigma `{P : A -> Type} + `{IsTrunc n A} `{forall a, IsTrunc n (P a)} +: IsTrunc n (sigT P) | 100. + +Proof. + generalize dependent A. + induction n; [ | admit ]; simpl; intros A P ac Pc. + (exists (existT _ (center A) (center (P (center A))))). + intros [a ?]. + refine (path_sigma' P (contr a) (path_contr _ _)). +Defined. +Inductive Bool : Set := true | false. +Definition trunc_sum' n A B `{IsTrunc n Bool, IsTrunc n A, IsTrunc n B} +: (IsTrunc n { b : Bool & if b then A else B }). +Proof. + Set Printing All. + Set Printing Universes. + refine (@trunc_sigma Bool (fun b => if b then A else B) n _ _). + (* Toplevel input, characters 23-76: +Error: +In environment +n : trunc_index +A : Type (* Top.193 *) +B : Type (* Top.194 *) +H : IsTrunc (* Set *) n Bool +H0 : IsTrunc (* Top.193 *) n A +H1 : IsTrunc (* Top.194 *) n B +The term + "@trunc_sigma (* Top.198 Top.199 Top.200 Top.201 *) Bool + (fun b : Bool => + match b return Type (* Top.199 *) with + | true => A + | false => B + end) n ?49 ?50" has type + "IsTrunc (* Top.200 *) n + (@sig (* Top.199 Top.199 *) Bool + (fun b : Bool => + match b return Type (* Top.199 *) with + | true => A + | false => B + end))" while it is expected to have type + "IsTrunc (* Top.195 *) n + (@sig (* Set Top.197 *) Bool + (fun b : Bool => + match b return Type (* Top.197 *) with + | true => A + | false => B + end))" (Universe inconsistency: Cannot enforce Top.197 = Set)). + *) + admit. +Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_108.v b/test-suite/bugs/closed/HoTT_coq_108.v new file mode 100644 index 00000000..cc304802 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_108.v @@ -0,0 +1,127 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* NOTE: This bug is only triggered with -load-vernac-source / in interactive mode. *) +(* File reduced by coq-bug-finder from 139 lines to 124 lines. *) +Set Universe Polymorphism. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Generalizable All Variables. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) +: forall x, f x = g x + := fun x => match h with idpath => idpath end. + +Definition ap11 {A B} {f g:A->B} (h:f=g) {x y:A} (p:x=y) : f x = g y. + admit. +Defined. +Class IsEquiv {A B : Type} (f : A -> B) := {}. +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) + }. + +Arguments center A {_}. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint nat_to_trunc_index (n : nat) : trunc_index + := match n with + | 0 => trunc_S (trunc_S minus_two) + | S n' => trunc_S (nat_to_trunc_index n') + end. + +Coercion nat_to_trunc_index : nat >-> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A) +: IsTrunc n (x = y) + := H x y. + +Notation Contr := (IsTrunc minus_two). + +Notation IsHSet := (IsTrunc 0). + +Class Funext := + { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. +Global Instance contr_forall `{Funext} `{P : A -> Type} `{forall a, Contr (P a)} +: Contr (forall a, P a) | 100. +admit. +Defined. +Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances. +Global Instance trunc_forall `{Funext} `{P : A -> Type} `{forall a, IsTrunc n (P a)} +: IsTrunc n (forall a, P a) | 100. +Proof. + generalize dependent P. + induction n as [ | n' IH]; [ | admit ]; simpl; intros P ?. + exact _. +Defined. +Set Implicit Arguments. + +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + identity : forall x, morphism x x; + compose : forall s d d', morphism d d' -> morphism s d -> morphism s d'; + trunc_morphism : forall s d, IsHSet (morphism s d) }. + +Existing Instance trunc_morphism. +Infix "o" := (@compose _ _ _ _) : morphism_scope. +Local Open Scope morphism_scope. + +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + composition_of : forall s d d' + (m1 : morphism C s d) (m2: morphism C d d'), + morphism_of _ _ (m2 o m1) + = (morphism_of _ _ m2) o (morphism_of _ _ m1); + identity_of : forall x, morphism_of _ _ (@identity _ x) + = @identity _ (object_of x) }. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Section path_functor. + Context `{Funext}. + Variable C : PreCategory. + Variable D : PreCategory. + Local Notation path_functor'_T F G + := { HO : object_of F = object_of G + | transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d)) + HO + (morphism_of F) + = morphism_of G } + (only parsing). + Definition path_functor'_sig (F G : Functor C D) : path_functor'_T F G -> F = G. + Proof. + intros [H' H'']. + destruct F, G; simpl in *. + induction H'. (* while destruct H' works *) destruct H''. + apply ap11; [ apply ap | ]; + apply center; abstract exact _. + Set Printing Universes. + (* Fail Defined.*) + (* The command has indeed failed with message: +=> Error: path_functor'_sig_subproof already exists. *) + Defined. +(* Anomaly: Backtrack.backto 55: a state with no vcs_backup. Please report. *) +End path_functor. diff --git a/test-suite/bugs/closed/HoTT_coq_110.v b/test-suite/bugs/closed/HoTT_coq_110.v new file mode 100644 index 00000000..5ec40dbc --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_110.v @@ -0,0 +1,23 @@ +Module X. + Inductive paths A (x : A) : A -> Type := idpath : paths A x x. + Notation "x = y" := (@paths _ x y) : type_scope. + + Axioms A B : Type. + Axiom P : A = B. + Definition foo : A = B. + abstract (rewrite <- P; reflexivity). + (* Error: internal_paths_rew already exists. *) + Defined. (* Anomaly: Uncaught exception Not_found(_). Please report. *) +End X. + +Module Y. + Inductive paths A (x : A) : A -> Type := idpath : paths A x x. + Notation "x = y" := (@paths _ x y) : type_scope. + + Axioms A B : Type. + Axiom P : A = B. + Definition foo : (A = B) * (A = B). + split; abstract (rewrite <- P; reflexivity). + (* Error: internal_paths_rew already exists. *) + Defined. (* Anomaly: Uncaught exception Not_found(_). Please report. *) +End Y. diff --git a/test-suite/bugs/closed/HoTT_coq_111.v b/test-suite/bugs/closed/HoTT_coq_111.v new file mode 100644 index 00000000..3b43f31d --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_111.v @@ -0,0 +1,24 @@ + +Module X. + (*Set Universe Polymorphism.*) + Inductive paths A (x : A) : forall _ : A, Type := idpath : paths A x x. + Notation "x = y" := (@paths _ x y) (at level 70, no associativity) : type_scope. + + Axioms A B : Type. + Axiom P : A = B. + Definition foo : A = B. + abstract (rewrite <- P; reflexivity). + Defined. +End X. + +Module Y. + (*Set Universe Polymorphism.*) + Inductive paths A (x : A) : forall _ : A, Type := idpath : paths A x x. + Notation "x = y" := (@paths _ x y) (at level 70, no associativity) : type_scope. + + Axioms A B : Type. + Axiom P : A = B. + Definition foo : (A = B) * (A = B). + split; abstract (rewrite <- P; reflexivity). + Defined. +End Y. diff --git a/test-suite/bugs/closed/HoTT_coq_112.v b/test-suite/bugs/closed/HoTT_coq_112.v new file mode 100644 index 00000000..150f2ecc --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_112.v @@ -0,0 +1,75 @@ +(* File reduced by coq-bug-finder from 4464 lines to 4137 lines, then from 3683 lines to 118 lines, then from 124 lines to 75 lines. *) +Set Universe Polymorphism. +Definition admit {T} : T. +Admitted. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) + : forall x, f x = g x + := fun x => match h with idpath => idpath end. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : forall x, f (equiv_inv x) = x +}. + +Arguments eisretr {A B} f {_} _. + +Record Equiv A B := BuildEquiv { + equiv_fun :> A -> B ; + equiv_isequiv :> IsEquiv equiv_fun +}. + +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. +Local Open Scope equiv_scope. + +Instance isequiv_path {A B : Type} (p : A = B) + : IsEquiv (transport (fun X:Type => X) p) | 0 + := admit. +Definition equiv_path (A B : Type) (p : A = B) : A <~> B + := BuildEquiv _ _ (transport (fun X:Type => X) p) _. + +Class Univalence := { + isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B) +}. + +Section Univalence. + Context `{Univalence}. + + Definition path_universe_uncurried {A B : Type} (f : A <~> B) : A = B + := (equiv_path A B)^-1 f. + + Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B) + := path_universe_uncurried (BuildEquiv _ _ f feq). + + Set Printing Universes. + Definition transport_path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A) + : transport (fun X:Type => X) (path_universe f) z = f z + := apD10 (ap (equiv_fun A B) (eisretr (equiv_path A B) (BuildEquiv _ _ f feq))) z. + (* Toplevel input, characters 0-231: +Error: Illegal application: +The term "isequiv_equiv_path (* Top.1003 Top.1003 Top.1001 Top.997 *)" +of type + "Univalence (* Top.1003 Top.1003 Top.1001 Top.997 *) -> + forall (A : Type (* Top.1003 *)) (B : Type (* Top.997 *)), + IsEquiv (* Top.1003 Top.1001 *) + (equiv_path (* Top.997 Top.1003 Top.1001 Top.1003 *) A B)" +cannot be applied to the terms + "H" : "Univalence (* Top.934 Top.935 Top.936 Top.937 *)" + "A" : "Type (* Top.996 *)" + "B" : "Type (* Top.997 *)" +The 1st term has type "Univalence (* Top.934 Top.935 Top.936 Top.937 *)" +which should be coercible to + "Univalence (* Top.1003 Top.1003 Top.1001 Top.997 *)". + *) diff --git a/test-suite/bugs/closed/HoTT_coq_113.v b/test-suite/bugs/closed/HoTT_coq_113.v new file mode 100644 index 00000000..3ef531bc --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_113.v @@ -0,0 +1,19 @@ +(* File reduced by coq-bug-finder from original input, then from 3329 lines to 153 lines, then from 118 lines to 49 lines, then from 55 lines to 38 lines, then from 46 lines to 16 lines *) + +Generalizable All Variables. +Set Universe Polymorphism. +Class Foo (A : Type) := {}. +Definition Baz := Foo. +Definition Bar {A B} `{Foo A, Foo B} : True. +Proof. + Set Printing Universes. + (* [change] should give fresh universes for each [Foo] *) + change Foo with Baz in *. + admit. +Defined. +Definition foo := @Bar nat. +Check @foo Set. +(* Toplevel input, characters 26-29: +Error: +The term "Set" has type "Type (* Set+1 *)" while it is expected to have type + "Set" (Universe inconsistency: Cannot enforce Set < Set because Set = Set)). *) diff --git a/test-suite/bugs/closed/HoTT_coq_114.v b/test-suite/bugs/closed/HoTT_coq_114.v new file mode 100644 index 00000000..34112833 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_114.v @@ -0,0 +1 @@ +Inductive test : $(let U := type of Type in exact U)$ := t. diff --git a/test-suite/bugs/closed/HoTT_coq_115.v b/test-suite/bugs/closed/HoTT_coq_115.v new file mode 100644 index 00000000..c1e133ee --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_115.v @@ -0,0 +1 @@ +Inductive T : let U := Type in U := t. (* Anomaly: not an arity. Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_116.v b/test-suite/bugs/closed/HoTT_coq_116.v new file mode 100644 index 00000000..d408557d --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_116.v @@ -0,0 +1,13 @@ +Set Universe Polymorphism. +Section foo. + Let U := Type. + Let U' : Type. + Proof. + let U' := constr:(Type) in + let U_le_U' := constr:(fun x : U => (x : U')) in + exact U'. + Defined. + Inductive t : U' := . +End foo. +(* Toplevel input, characters 15-23: +Error: No such section variable or assumption: U'. *) diff --git a/test-suite/bugs/closed/HoTT_coq_117.v b/test-suite/bugs/closed/HoTT_coq_117.v new file mode 100644 index 00000000..5fbcfef4 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_117.v @@ -0,0 +1,25 @@ +(* File reduced by coq-bug-finder from original input, then from 1461 lines to 81 lines, then from 84 lines to 40 lines, then from 50 lines to 24 lines *) + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) +}. +Class Funext := {}. + +Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : + (forall x, f x = g x) -> f = g. + +Admitted. + +Inductive Empty : Set := . +Instance contr_from_Empty {_ : Funext} (A : Type) : + Contr_internal (Empty -> A) := + BuildContr _ + (Empty_rect (fun _ => A)) + (fun f => path_forall _ f (fun x => Empty_rect _ x)). +(* Toplevel input, characters 15-220: +Anomaly: unknown meta ?190. Please report. *) diff --git a/test-suite/bugs/closed/HoTT_coq_118.v b/test-suite/bugs/closed/HoTT_coq_118.v new file mode 100644 index 00000000..14ad0e49 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_118.v @@ -0,0 +1,35 @@ +(* File reduced by coq-bug-finder from original input, then from 5631 lines to 557 lines, then from 526 lines to 181 lines, then from 189 lines to 154 lines, then from 153 lines to 107 lines, then from 97 lines to 56 lines, then from 50 lines to 37 lines *) +Generalizable All Variables. +Set Universe Polymorphism. +Definition admit {T} : T. +Admitted. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (@paths _ x y) : type_scope. +Class Contr_internal (A : Type) := BuildContr { center : A }. +Arguments center A {_}. +Instance contr_paths_contr `{Contr_internal A} (x y : A) : Contr_internal (x = y) := admit. +Inductive Unit : Set := tt. +Instance contr_unit : Contr_internal Unit | 0 := admit. +Record PreCategory := { morphism : Type }. +Class IsIsomorphism {C : PreCategory} (m : morphism C) := { left_inverse : m = m }. +Definition indiscrete_category : PreCategory := @Build_PreCategory Unit. +Goal forall (X : Type) (_ : forall x y : X, Contr_internal (@paths X x y)) (s : X), + @IsIsomorphism indiscrete_category tt -> True. +Proof. + intros X H s [p]. + simpl in *. + assert (idpath = p). + clear. + assert (H : forall p : tt = tt, idpath = p) by (intro; exact (center _)). + clear H. + exact (center _). + (* Toplevel input, characters 15-32: +Error: +Unable to satisfy the following constraints: +In environment: +p : tt = tt + +?46 : "Contr_internal (idpath = p)" + *) diff --git a/test-suite/bugs/closed/HoTT_coq_121.v b/test-suite/bugs/closed/HoTT_coq_121.v new file mode 100644 index 00000000..cce288cf --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_121.v @@ -0,0 +1,18 @@ +(* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines, then from 146 lines to 72 lines, then from 82 lines to 70 lines, then from 79 lines to 49 lines, then from 59 lines to 16 lines *) + +Set Universe Polymorphism. +Generalizable All Variables. +Record hSet := BuildhSet {setT:> Type}. +Axiom minus1Trunc : Type -> Type. +Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT P). +Definition issurj {X Y} (f:X->Y) := forall y:Y, hexists (fun x => (f x) = y). +Lemma isepi_issurj {X Y} (f:X->Y): issurj f. +Proof. + intros y. + admit. +Defined. (* Toplevel input, characters 15-23: +Error: Unsatisfied constraints: +Top.38 <= Coq.Init.Specif.7 +Top.43 <= Top.38 +Top.43 <= Coq.Init.Specif.8 + (maybe a bugged tactic). *) diff --git a/test-suite/bugs/closed/HoTT_coq_122.v b/test-suite/bugs/closed/HoTT_coq_122.v new file mode 100644 index 00000000..1ba8e5c3 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_122.v @@ -0,0 +1,25 @@ +(* File reduced by coq-bug-finder from original input, then from 669 lines to 79 lines, then from 89 lines to 44 lines *) +Set Primitive Projections. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Notation "x = y" := (@paths _ x y) : type_scope. + +Set Implicit Arguments. + +Record PreCategory := + Build_PreCategory' { + object :> Type; + morphism : object -> object -> Type; + + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + left_identity : forall a b (f : morphism a b), identity b o f = f + }. + +Hint Rewrite @left_identity. (* stack overflow *) diff --git a/test-suite/bugs/closed/HoTT_coq_123.v b/test-suite/bugs/closed/HoTT_coq_123.v new file mode 100644 index 00000000..994dff63 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_123.v @@ -0,0 +1,171 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") *) +(* File reduced by coq-bug-finder from original input, then from 4988 lines to 856 lines, then from 648 lines to 398 lines, then from 401 lines to 332 lines, then from 287 lines to 250 lines, then from 257 lines to 241 lines, then from 223 lines to 175 lines *) +Set Universe Polymorphism. +Set Asymmetric Patterns. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Generalizable All Variables. +Definition admit {T} : T. +Admitted. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (@paths _ x y) : type_scope. +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) : Type + := forall x:A, f x = g x. +Hint Unfold pointwise_paths : typeclass_instances. +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) +: forall x, f x = g x + := fun x => match h with idpath => idpath end. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }. + +Record Equiv A B := BuildEquiv { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }. +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope. +Class Contr_internal (A : Type) := {}. +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A) +: IsTrunc n (x = y) + := H x y. + +Notation IsHSet := (IsTrunc minus_two). + +Class Funext := + { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. + +Local Open Scope equiv_scope. + +Global Instance isequiv_inverse `{IsEquiv A B f} : IsEquiv f^-1 | 10000 + := BuildIsEquiv B A f^-1 f. +Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. + +admit. + +Defined. +Definition trunc_equiv `(f : A -> B) + `{IsTrunc n A} `{IsEquiv A B f} +: IsTrunc n B. + admit. +Defined. +Definition trunc_equiv' `(f : A <~> B) `{IsTrunc n A} +: IsTrunc n B + := admit. +Set Implicit Arguments. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory := + Build_PreCategory { + object :> Type; + morphism : object -> object -> Type; + + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1); + + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f; + + trunc_morphism : forall s d, IsHSet (morphism s d) + }. +Existing Instance trunc_morphism. + +Infix "o" := (@compose _ _ _ _) : morphism_scope. +Delimit Scope functor_scope with functor. + +Local Open Scope morphism_scope. +Record Functor (C D : PreCategory) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) + }. + +Global Instance trunc_forall `{Funext} `{P : A -> Type} `{forall a, IsTrunc n (P a)} +: IsTrunc n (forall a, P a) | 100. +Proof. + generalize dependent P. + induction n as [ | n' IH]; (simpl; intros P ?). + - admit. + - pose (fun f g => trunc_equiv (@apD10 A P f g) ^-1); admit. +Defined. +Instance trunc_sigma `{P : A -> Type} + `{IsTrunc n A} `{forall a, IsTrunc n (P a)} +: IsTrunc n (sigT P) | 100. +admit. +Defined. +Record NaturalTransformation C D (F G : Functor C D) := + Build_NaturalTransformation' { + components_of :> forall c, morphism D (F c) (G c) + }. +Section path_natural_transformation. + Context `{Funext}. + Variable C : PreCategory. + Variable D : PreCategory. + Variables F G : Functor C D. + Lemma equiv_sig_natural_transformation + : { CO : forall x, morphism D (F x) (G x) + & forall s d (m : morphism C s d), + CO d o morphism_of F _ _ m = morphism_of G _ _ m o CO s } + <~> NaturalTransformation F G. + + admit. + Defined. + Global Instance trunc_natural_transformation + : IsHSet (NaturalTransformation F G). + Proof. + eapply trunc_equiv'; [ exact equiv_sig_natural_transformation | ]. + typeclasses eauto. + Qed. + Lemma path_natural_transformation (T U : NaturalTransformation F G) + : components_of T == components_of U + -> T = U. + admit. + Defined. +End path_natural_transformation. +Ltac path_natural_transformation := + repeat match goal with + | _ => intro + | _ => apply path_natural_transformation; simpl + end. + +Section FunctorSectionCategory. + Context `{Funext}. + Variable C : PreCategory. + Variable D : PreCategory. + + Definition category_of_sections : PreCategory. + Proof. + refine (@Build_PreCategory + (Functor D C) + (fun F G => NaturalTransformation F G) + admit + admit + _ + _ + _ + _); + abstract (path_natural_transformation; admit). + Defined. (* Stack overflow *) diff --git a/test-suite/bugs/closed/HoTT_coq_124.v b/test-suite/bugs/closed/HoTT_coq_124.v new file mode 100644 index 00000000..e6e90ada --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_124.v @@ -0,0 +1,29 @@ +Set Implicit Arguments. +Set Primitive Projections. + +Polymorphic Inductive eqp A (x : A) : A -> Type := eqp_refl : eqp x x. +Monomorphic Inductive eqm A (x : A) : A -> Type := eqm_refl : eqm x x. + +Polymorphic Record prodp (A B : Type) : Type := pairp { fstp : A; sndp : B }. +Monomorphic Record prodm (A B : Type) : Type := pairm { fstm : A; sndm : B }. + +Check eqm_refl _ : eqm (fun x : prodm Set Set => pairm (fstm x) (sndm x)) (fun x => x). (* success *) +Check eqp_refl _ : eqp (fun x : prodm Set Set => pairm (fstm x) (sndm x)) (fun x => x). (* success *) +Check eqm_refl _ : eqm (fun x : prodp Set Set => pairp (fstp x) (sndp x)) (fun x => x). (* Error: +The term + "eqm_refl (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})" +has type + "eqm (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |}) + (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})" +while it is expected to have type + "eqm (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |}) + (fun x : prodp Set Set => x)". *) +Check eqp_refl _ : eqp (fun x : prodp Set Set => pairp (fstp x) (sndp x)) (fun x => x). (* Error: +The term + "eqp_refl (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})" +has type + "eqp (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |}) + (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})" +while it is expected to have type + "eqp (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |}) + (fun x : prodp Set Set => x)". *) diff --git a/test-suite/bugs/closed/shouldfail/1703.v b/test-suite/bugs/closed/shouldfail/1703.v deleted file mode 100644 index 6b5198cc..00000000 --- a/test-suite/bugs/closed/shouldfail/1703.v +++ /dev/null @@ -1,7 +0,0 @@ -(* Check correct binding of intros until used in Ltac *) - -Ltac intros_until n := intros until n. - -Goal forall i j m n : nat, i = 0 /\ j = 0 /\ m = 0 /\ n = 0. -intro i. -intros until i. diff --git a/test-suite/bugs/closed/shouldfail/1898.v b/test-suite/bugs/closed/shouldfail/1898.v deleted file mode 100644 index 92490eb9..00000000 --- a/test-suite/bugs/closed/shouldfail/1898.v +++ /dev/null @@ -1,5 +0,0 @@ -(* folding should not allow circular dependencies *) - -Lemma bug_fold_unfold : True. - set (h := 1). - fold h in h. diff --git a/test-suite/bugs/closed/shouldfail/1915.v b/test-suite/bugs/closed/shouldfail/1915.v deleted file mode 100644 index a96a482c..00000000 --- a/test-suite/bugs/closed/shouldfail/1915.v +++ /dev/null @@ -1,6 +0,0 @@ - -Require Import Setoid. - -Goal forall x, impl True (x = 0) -> x = 0 -> False. -intros x H E. -rewrite H in E. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldfail/2006.v b/test-suite/bugs/closed/shouldfail/2006.v deleted file mode 100644 index 91a16f95..00000000 --- a/test-suite/bugs/closed/shouldfail/2006.v +++ /dev/null @@ -1,23 +0,0 @@ -(* Take the type constraint on Record into account *) - -Definition Type1 := Type. -Record R : Type1 := { p:Type1 }. (* was accepted before trunk revision 11619 *) - -(* -Remarks: - -- The behaviour was inconsistent with the one of Inductive, e.g. - - Inductive R : Type1 := Build_R : Type1 -> R. - - was correctly refused. - -- CoRN makes some use of the following configuration: - - Definition CProp := Type. - Record R : CProp := { ... }. - - CoRN may have to change the CProp definition into a notation if the - preservation of the former semantics of Record type constraints - turns to be required. -*) diff --git a/test-suite/bugs/closed/shouldfail/2251.v b/test-suite/bugs/closed/shouldfail/2251.v deleted file mode 100644 index 642717f4..00000000 --- a/test-suite/bugs/closed/shouldfail/2251.v +++ /dev/null @@ -1,5 +0,0 @@ -(* Check that rewrite does not apply to single evars *) - -Lemma evar_rewrite : (forall a : nat, a = 0 -> True) -> True. -intros; eapply H. (* goal is ?30 = nil *) -rewrite plus_n_Sm. diff --git a/test-suite/bugs/closed/shouldfail/2406.v b/test-suite/bugs/closed/shouldfail/2406.v deleted file mode 100644 index 112ea2bb..00000000 --- a/test-suite/bugs/closed/shouldfail/2406.v +++ /dev/null @@ -1,3 +0,0 @@ -(* Check correct handling of unsupported notations *) -Notation "'’'" := (fun x => x) (at level 20). -Definition crash_the_rooster f := ’. diff --git a/test-suite/bugs/closed/shouldfail/2586.v b/test-suite/bugs/closed/shouldfail/2586.v deleted file mode 100644 index 6111a641..00000000 --- a/test-suite/bugs/closed/shouldfail/2586.v +++ /dev/null @@ -1,5 +0,0 @@ -Require Import Setoid SetoidClass Program. - -Goal forall `(Setoid nat) x y, x == y -> S x == S y. - intros. - clsubst H0. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1041.v b/test-suite/bugs/closed/shouldsucceed/1041.v deleted file mode 100644 index a5de82e0..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1041.v +++ /dev/null @@ -1,13 +0,0 @@ -Goal Prop. - -pose (P:=(fun x y :Prop => y)). -evar (Q: (forall X Y,P X Y -> Prop)) . - -instantiate (1:= fun _ => _ ) in (Value of Q). -instantiate (1:= fun _ => _ ) in (Value of Q). -instantiate (1:= fun _ => _ ) in (Value of Q). - -instantiate (1:=H) in (Value of Q). - -Admitted. - diff --git a/test-suite/bugs/closed/shouldsucceed/1100.v b/test-suite/bugs/closed/shouldsucceed/1100.v deleted file mode 100644 index 32c78b4b..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1100.v +++ /dev/null @@ -1,12 +0,0 @@ -Require Import Setoid. - -Parameter P : nat -> Prop. -Parameter Q : nat -> Prop. -Parameter PQ : forall n, P n <-> Q n. - -Lemma PQ2 : forall n, P n -> Q n. - intros. - rewrite PQ in H. - trivial. -Qed. - diff --git a/test-suite/bugs/closed/shouldsucceed/121.v b/test-suite/bugs/closed/shouldsucceed/121.v deleted file mode 100644 index 8c5a3885..00000000 --- a/test-suite/bugs/closed/shouldsucceed/121.v +++ /dev/null @@ -1,17 +0,0 @@ -Require Import Setoid. - -Section Setoid_Bug. - -Variable X:Type -> Type. -Variable Xeq : forall A, (X A) -> (X A) -> Prop. -Hypothesis Xst : forall A, Equivalence (Xeq A). - -Variable map : forall A B, (A -> B) -> X A -> X B. - -Implicit Arguments map [A B]. - -Goal forall A B (a b:X (B -> A)) (c:X A) (f:A -> B -> A), Xeq _ a b -> Xeq _ b (map f c) -> Xeq _ a (map f c). -intros A B a b c f Hab Hbc. -rewrite Hab. -assumption. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1243.v b/test-suite/bugs/closed/shouldsucceed/1243.v deleted file mode 100644 index 7d6781db..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1243.v +++ /dev/null @@ -1,12 +0,0 @@ -Require Import ZArith. -Require Import Arith. -Open Scope Z_scope. - -Theorem r_ex : (forall x y:nat, x + y = x + y)%nat. -Admitted. - -Theorem r_ex' : forall x y:nat, (x + y = x + y)%nat. -Admitted. - - - diff --git a/test-suite/bugs/closed/shouldsucceed/1302.v b/test-suite/bugs/closed/shouldsucceed/1302.v deleted file mode 100644 index e94dfcfb..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1302.v +++ /dev/null @@ -1,22 +0,0 @@ -Module Type T. - -Parameter A : Type. - -Inductive L : Type := -| L0 : L (* without this constructor, it works right *) -| L1 : A -> L. - -End T. - -Axiom Tp : Type. - -Module TT : T. - -Definition A : Type := Tp. - -Inductive L : Type := -| L0 : L -| L1 : A -> L. - -End TT. - diff --git a/test-suite/bugs/closed/shouldsucceed/1322.v b/test-suite/bugs/closed/shouldsucceed/1322.v deleted file mode 100644 index 1ec7d452..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1322.v +++ /dev/null @@ -1,24 +0,0 @@ -Require Import Setoid. - -Section transition_gen. - -Variable I : Type. -Variable I_eq :I -> I -> Prop. -Variable I_eq_equiv : Setoid_Theory I I_eq. - -(* Add Relation I I_eq - reflexivity proved by I_eq_equiv.(Seq_refl I I_eq) - symmetry proved by I_eq_equiv.(Seq_sym I I_eq) - transitivity proved by I_eq_equiv.(Seq_trans I I_eq) -as I_eq_relation. *) - -Add Setoid I I_eq I_eq_equiv as I_with_eq. - -Variable F : I -> Type. -Variable F_morphism : forall i j, I_eq i j -> F i = F j. - - -Add Morphism F with signature I_eq ==> (@eq _) as F_morphism2. -Admitted. - -End transition_gen. diff --git a/test-suite/bugs/closed/shouldsucceed/1411.v b/test-suite/bugs/closed/shouldsucceed/1411.v deleted file mode 100644 index a1a7b288..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1411.v +++ /dev/null @@ -1,35 +0,0 @@ -Require Import List. -Require Import Program. - -Inductive Tree : Set := -| Br : Tree -> Tree -> Tree -| No : nat -> Tree -. - -(* given a tree, we want to know which lists can - be used to navigate exactly to a node *) -Inductive Exact : Tree -> list bool -> Prop := -| exDone n : Exact (No n) nil -| exLeft l r p: Exact l p -> Exact (Br l r) (true::p) -| exRight l r p: Exact r p -> Exact (Br l r) (false::p) -. - -Definition unreachable A : False -> A. -intros. -destruct H. -Defined. - -Program Fixpoint fetch t p (x:Exact t p) {struct t} := - match t, p with - | No p' , nil => p' - | No p' , _::_ => unreachable nat _ - | Br l r, nil => unreachable nat _ - | Br l r, true::t => fetch l t _ - | Br l r, false::t => fetch r t _ - end. - -Next Obligation. inversion x. Qed. -Next Obligation. inversion x. Qed. -Next Obligation. inversion x; trivial. Qed. -Next Obligation. inversion x; trivial. Qed. - diff --git a/test-suite/bugs/closed/shouldsucceed/1414.v b/test-suite/bugs/closed/shouldsucceed/1414.v deleted file mode 100644 index ee9e2504..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1414.v +++ /dev/null @@ -1,40 +0,0 @@ -Require Import ZArith Coq.Program.Wf Coq.Program.Utils. - -Parameter data:Set. - -Inductive t : Set := - | Leaf : t - | Node : t -> data -> t -> Z -> t. - -Parameter avl : t -> Prop. -Parameter bst : t -> Prop. -Parameter In : data -> t -> Prop. -Parameter cardinal : t -> nat. -Definition card2 (s:t*t) := let (s1,s2) := s in cardinal s1 + cardinal s2. - -Parameter split : data -> t -> t*(bool*t). -Parameter join : t -> data -> t -> t. -Parameter add : data -> t -> t. - -Program Fixpoint union - (s u:t) - (hb1: bst s)(ha1: avl s)(hb2: bst u)(hb2: avl u) - { measure (cardinal s + cardinal u) } : - {s' : t | bst s' /\ avl s' /\ forall x, In x s' <-> In x s \/ In x u} := - match s, u with - | Leaf,t2 => t2 - | t1,Leaf => t1 - | Node l1 v1 r1 h1, Node l2 v2 r2 h2 => - if (Z_ge_lt_dec h1 h2) then - if (Z.eq_dec h2 1) - then add v2 s - else - let (l2', r2') := split v1 u in - join (union l1 l2' _ _ _ _) v1 (union r1 (snd r2') _ _ _ _) - else - if (Z.eq_dec h1 1) - then add v1 s - else - let (l1', r1') := split v2 u in - join (union l1' l2 _ _ _ _) v2 (union (snd r1') r2 _ _ _ _) - end. diff --git a/test-suite/bugs/closed/shouldsucceed/1416.v b/test-suite/bugs/closed/shouldsucceed/1416.v deleted file mode 100644 index ee092005..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1416.v +++ /dev/null @@ -1,30 +0,0 @@ -(* In 8.1 autorewrite used to raised an anomaly here *) -(* After resolution of the bug, autorewrite succeeded *) -(* From forthcoming 8.4, autorewrite is forbidden to instantiate *) -(* evars, so the new test just checks it is not an anomaly *) - -Set Implicit Arguments. - -Record Place (Env A: Type) : Type := { - read: Env -> A ; - write: Env -> A -> Env ; - write_read: forall (e:Env), (write e (read e))=e -}. - -Hint Rewrite -> write_read: placeeq. - -Record sumPl (Env A B: Type) (vL:(Place Env A)) (vR:(Place Env B)) : Type := - { - mkEnv: A -> B -> Env ; - mkEnv2writeL: forall (e:Env) (x:A), (mkEnv x (read vR e))=(write vL e x) - }. - -(* when the following line is commented, the bug does not appear *) -Hint Rewrite -> mkEnv2writeL: placeeq. - -Lemma autorewrite_raise_anomaly: forall (Env A:Type) (e: Env) (p:Place Env A), - (exists e1:Env, e=(write p e1 (read p e))). -Proof. - intros Env A e p; eapply ex_intro. - autorewrite with placeeq. (* Here is the bug *) - diff --git a/test-suite/bugs/closed/shouldsucceed/1419.v b/test-suite/bugs/closed/shouldsucceed/1419.v deleted file mode 100644 index d021107d..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1419.v +++ /dev/null @@ -1,8 +0,0 @@ -Goal True. - set(a := 0). - set(b := a). - unfold a in b. - clear a. - Eval vm_compute in b. - trivial. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1425.v b/test-suite/bugs/closed/shouldsucceed/1425.v deleted file mode 100644 index 6be30174..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1425.v +++ /dev/null @@ -1,19 +0,0 @@ -Require Import Setoid. - -Parameter recursion : forall A : Set, A -> (nat -> A -> A) -> nat -> A. - -Axiom recursion_S : - forall (A : Set) (EA : relation A) (a : A) (f : nat -> A -> A) (n : nat), - EA (recursion A a f (S n)) (f n (recursion A a f n)). - -Goal forall n : nat, recursion nat 0 (fun _ _ => 1) (S n) = 1. -intro n. -rewrite recursion_S. -reflexivity. -Qed. - -Goal forall n : nat, recursion nat 0 (fun _ _ => 1) (S n) = 1. -intro n. -setoid_rewrite recursion_S. -reflexivity. -Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1446.v b/test-suite/bugs/closed/shouldsucceed/1446.v deleted file mode 100644 index 8cb2d653..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1446.v +++ /dev/null @@ -1,20 +0,0 @@ -Lemma not_true_eq_false : forall (b:bool), b <> true -> b = false. -Proof. - destruct b;intros;trivial. - elim H. - exact (refl_equal true). -Qed. - -Section BUG. - - Variable b : bool. - Hypothesis H : b <> true. - Hypothesis H0 : b = true. - Hypothesis H1 : b <> true. - - Goal False. - rewrite (not_true_eq_false _ H) in * |-. - contradiction. - Qed. - -End BUG. diff --git a/test-suite/bugs/closed/shouldsucceed/1448.v b/test-suite/bugs/closed/shouldsucceed/1448.v deleted file mode 100644 index fe3b4c8b..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1448.v +++ /dev/null @@ -1,28 +0,0 @@ -Require Import Relations. -Require Import Setoid. -Require Import Ring_theory. -Require Import Ring_base. - - -Variable R : Type. -Variable Rone Rzero : R. -Variable Rplus Rmult Rminus : R -> R -> R. -Variable Rneg : R -> R. - -Lemma my_ring_theory : @ring_theory R Rzero Rone Rplus Rmult Rminus Rneg (@eq -R). -Admitted. - -Variable Req : R -> R -> Prop. - -Hypothesis Req_refl : reflexive _ Req. -Hypothesis Req_sym : symmetric _ Req. -Hypothesis Req_trans : transitive _ Req. - -Add Relation R Req - reflexivity proved by Req_refl - symmetry proved by Req_sym - transitivity proved by Req_trans - as Req_rel. - -Add Ring my_ring : my_ring_theory (abstract). diff --git a/test-suite/bugs/closed/shouldsucceed/1477.v b/test-suite/bugs/closed/shouldsucceed/1477.v deleted file mode 100644 index dfc8c328..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1477.v +++ /dev/null @@ -1,18 +0,0 @@ -Inductive I : Set := - | A : nat -> nat -> I - | B : nat -> nat -> I. - -Definition foo1 (x:I) : nat := - match x with - | A a b | B a b => S b - end. - -Definition foo2 (x:I) : nat := - match x with - | A _ b | B b _ => S b - end. - -Definition foo (x:I) : nat := - match x with - | A a b | B b a => S b - end. diff --git a/test-suite/bugs/closed/shouldsucceed/1483.v b/test-suite/bugs/closed/shouldsucceed/1483.v deleted file mode 100644 index a3d7f168..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1483.v +++ /dev/null @@ -1,10 +0,0 @@ -Require Import BinPos. - -Definition P := (fun x : positive => x = xH). - -Goal forall (p q : positive), P q -> q = p -> P p. -intros; congruence. -Qed. - - - diff --git a/test-suite/bugs/closed/shouldsucceed/1507.v b/test-suite/bugs/closed/shouldsucceed/1507.v deleted file mode 100644 index f2ab9100..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1507.v +++ /dev/null @@ -1,120 +0,0 @@ -(* - Implementing reals a la Stolzenberg - - Danko Ilik, March 2007 - - XField.v -- (unfinished) axiomatisation of the theories of real and - rational intervals. -*) - -Definition associative (A:Type)(op:A->A->A) := - forall x y z:A, op (op x y) z = op x (op y z). - -Definition commutative (A:Type)(op:A->A->A) := - forall x y:A, op x y = op y x. - -Definition trichotomous (A:Type)(R:A->A->Prop) := - forall x y:A, R x y \/ x=y \/ R y x. - -Definition relation (A:Type) := A -> A -> Prop. -Definition reflexive (A:Type)(R:relation A) := forall x:A, R x x. -Definition transitive (A:Type)(R:relation A) := - forall x y z:A, R x y -> R y z -> R x z. -Definition symmetric (A:Type)(R:relation A) := forall x y:A, R x y -> R y x. - -Record interval (X:Set)(le:X->X->Prop) : Set := - interval_make { - interval_left : X; - interval_right : X; - interval_nonempty : le interval_left interval_right - }. - -Record I (grnd:Set)(le:grnd->grnd->Prop) : Type := Imake { - Icar := interval grnd le; - Iplus : Icar -> Icar -> Icar; - Imult : Icar -> Icar -> Icar; - Izero : Icar; - Ione : Icar; - Iopp : Icar -> Icar; - Iinv : Icar -> Icar; - Ic : Icar -> Icar -> Prop; (* consistency *) - (* monoids *) - Iplus_assoc : associative Icar Iplus; - Imult_assoc : associative Icar Imult; - (* abelian groups *) - Iplus_comm : commutative Icar Iplus; - Imult_comm : commutative Icar Imult; - Iplus_0_l : forall x:Icar, Ic (Iplus Izero x) x; - Iplus_0_r : forall x:Icar, Ic (Iplus x Izero) x; - Imult_0_l : forall x:Icar, Ic (Imult Ione x) x; - Imult_0_r : forall x:Icar, Ic (Imult x Ione) x; - Iplus_opp_r : forall x:Icar, Ic (Iplus x (Iopp x)) (Izero); - Imult_inv_r : forall x:Icar, ~(Ic x Izero) -> Ic (Imult x (Iinv x)) Ione; - (* distributive laws *) - Imult_plus_distr_l : forall x x' y y' z z' z'', - Ic x x' -> Ic y y' -> Ic z z' -> Ic z z'' -> - Ic (Imult (Iplus x y) z) (Iplus (Imult x' z') (Imult y' z'')); - (* order and lattice structure *) - Ilt : Icar -> Icar -> Prop; - Ilc := fun (x y:Icar) => Ilt x y \/ Ic x y; - Isup : Icar -> Icar -> Icar; - Iinf : Icar -> Icar -> Icar; - Ilt_trans : transitive _ lt; - Ilt_trich : forall x y:Icar, Ilt x y \/ Ic x y \/ Ilt y x; - Isup_lub : forall x y z:Icar, Ilc x z -> Ilc y z -> Ilc (Isup x y) z; - Iinf_glb : forall x y z:Icar, Ilc x y -> Ilc x z -> Ilc x (Iinf y z); - (* order preserves operations? *) - (* properties of Ic *) - Ic_refl : reflexive _ Ic; - Ic_sym : symmetric _ Ic -}. - -Definition interval_set (X:Set)(le:X->X->Prop) := - (interval X le) -> Prop. (* can be Set as well *) -Check interval_set. -Check Ic. -Definition consistent (X:Set)(le:X->X->Prop)(TI:I X le)(p:interval_set X le) := - forall I J:interval X le, p I -> p J -> (Ic X le TI) I J. -Check consistent. -(* define 'fine' *) - -Record N (grnd:Set)(le:grnd->grnd->Prop)(grndI:I grnd le) : Type := Nmake { - Ncar := interval_set grnd le; - Nplus : Ncar -> Ncar -> Ncar; - Nmult : Ncar -> Ncar -> Ncar; - Nzero : Ncar; - None : Ncar; - Nopp : Ncar -> Ncar; - Ninv : Ncar -> Ncar; - Nc : Ncar -> Ncar -> Prop; (* Ncistency *) - (* monoids *) - Nplus_assoc : associative Ncar Nplus; - Nmult_assoc : associative Ncar Nmult; - (* abelian groups *) - Nplus_comm : commutative Ncar Nplus; - Nmult_comm : commutative Ncar Nmult; - Nplus_0_l : forall x:Ncar, Nc (Nplus Nzero x) x; - Nplus_0_r : forall x:Ncar, Nc (Nplus x Nzero) x; - Nmult_0_l : forall x:Ncar, Nc (Nmult None x) x; - Nmult_0_r : forall x:Ncar, Nc (Nmult x None) x; - Nplus_opp_r : forall x:Ncar, Nc (Nplus x (Nopp x)) (Nzero); - Nmult_inv_r : forall x:Ncar, ~(Nc x Nzero) -> Nc (Nmult x (Ninv x)) None; - (* distributive laws *) - Nmult_plus_distr_l : forall x x' y y' z z' z'', - Nc x x' -> Nc y y' -> Nc z z' -> Nc z z'' -> - Nc (Nmult (Nplus x y) z) (Nplus (Nmult x' z') (Nmult y' z'')); - (* order and lattice structure *) - Nlt : Ncar -> Ncar -> Prop; - Nlc := fun (x y:Ncar) => Nlt x y \/ Nc x y; - Nsup : Ncar -> Ncar -> Ncar; - Ninf : Ncar -> Ncar -> Ncar; - Nlt_trans : transitive _ lt; - Nlt_trich : forall x y:Ncar, Nlt x y \/ Nc x y \/ Nlt y x; - Nsup_lub : forall x y z:Ncar, Nlc x z -> Nlc y z -> Nlc (Nsup x y) z; - Ninf_glb : forall x y z:Ncar, Nlc x y -> Nlc x z -> Nlc x (Ninf y z); - (* order preserves operations? *) - (* properties of Nc *) - Nc_refl : reflexive _ Nc; - Nc_sym : symmetric _ Nc -}. - diff --git a/test-suite/bugs/closed/shouldsucceed/1519.v b/test-suite/bugs/closed/shouldsucceed/1519.v deleted file mode 100644 index 66bab241..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1519.v +++ /dev/null @@ -1,14 +0,0 @@ -Section S. - - Variable A:Prop. - Variable W:A. - - Remark T: A -> A. - intro Z. - rename W into Z_. - rename Z into W. - rename Z_ into Z. - exact Z. - Qed. - -End S. diff --git a/test-suite/bugs/closed/shouldsucceed/1568.v b/test-suite/bugs/closed/shouldsucceed/1568.v deleted file mode 100644 index 3609e9c8..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1568.v +++ /dev/null @@ -1,13 +0,0 @@ -CoInductive A: Set := - mk_A: B -> A -with B: Set := - mk_B: A -> B. - -CoFixpoint a:A := mk_A b -with b:B := mk_B a. - -Goal b = match a with mk_A a1 => a1 end. - simpl. reflexivity. -Qed. - - diff --git a/test-suite/bugs/closed/shouldsucceed/1576.v b/test-suite/bugs/closed/shouldsucceed/1576.v deleted file mode 100644 index 3621f7a1..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1576.v +++ /dev/null @@ -1,38 +0,0 @@ -Module Type TA. -Parameter t : Set. -End TA. - -Module Type TB. -Declare Module A: TA. -End TB. - -Module Type TC. -Declare Module B : TB. -End TC. - -Module Type TD. - -Declare Module B: TB . -Declare Module C: TC - with Module B := B . -End TD. - -Module Type TE. -Declare Module D : TD. -End TE. - -Module Type TF. -Declare Module E: TE. -End TF. - -Module G (D: TD). -Module B' := D.C.B. -End G. - -Module H (F: TF). -Module I := G(F.E.D). -End H. - -Declare Module F: TF. -Module K := H(F). - diff --git a/test-suite/bugs/closed/shouldsucceed/1582.v b/test-suite/bugs/closed/shouldsucceed/1582.v deleted file mode 100644 index be5d3dd2..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1582.v +++ /dev/null @@ -1,15 +0,0 @@ -Require Import Peano_dec. - -Definition fact_F : - forall (n:nat), - (forall m, m nat) -> - nat. -refine - (fun n fact_rec => - if eq_nat_dec n 0 then - 1 - else - let fn := fact_rec (n-1) _ in - n * fn). -Admitted. - diff --git a/test-suite/bugs/closed/shouldsucceed/1604.v b/test-suite/bugs/closed/shouldsucceed/1604.v deleted file mode 100644 index 22c3df82..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1604.v +++ /dev/null @@ -1,7 +0,0 @@ -Require Import Setoid. - -Parameter F : nat -> nat. -Axiom F_id : forall n : nat, n = F n. -Goal forall n : nat, F n = n. -intro n. setoid_rewrite F_id at 3. reflexivity. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1614.v b/test-suite/bugs/closed/shouldsucceed/1614.v deleted file mode 100644 index 6bc165d4..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1614.v +++ /dev/null @@ -1,21 +0,0 @@ -Require Import Ring. -Require Import ArithRing. - -Fixpoint eq_nat_bool (x y : nat) {struct x} : bool := -match x, y with -| 0, 0 => true -| S x', S y' => eq_nat_bool x' y' -| _, _ => false -end. - -Theorem eq_nat_bool_implies_eq : forall x y, eq_nat_bool x y = true -> x = y. -Proof. -induction x; destruct y; simpl; intro H; try (reflexivity || inversion H). -apply IHx in H; rewrite H; reflexivity. -Qed. - -Add Ring MyNatSRing : natSRth (decidable eq_nat_bool_implies_eq). - -Goal 0 = 0. - ring. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1618.v b/test-suite/bugs/closed/shouldsucceed/1618.v deleted file mode 100644 index a9b067ce..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1618.v +++ /dev/null @@ -1,23 +0,0 @@ -Inductive A: Set := -| A1: nat -> A. - -Definition A_size (a: A) : nat := - match a with - | A1 n => 0 - end. - -Require Import Recdef. - -Function n3 (P: A -> Prop) (f: forall n, P (A1 n)) (a: A) {struct a} : P a := - match a return (P a) with - | A1 n => f n - end. - - -Function n1 (P: A -> Prop) (f: forall n, P (A1 n)) (a: A) {measure A_size a} : -P -a := - match a return (P a) with - | A1 n => f n - end. - diff --git a/test-suite/bugs/closed/shouldsucceed/1634.v b/test-suite/bugs/closed/shouldsucceed/1634.v deleted file mode 100644 index 0150c250..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1634.v +++ /dev/null @@ -1,24 +0,0 @@ -Require Export Relation_Definitions. -Require Export Setoid. - -Variable A : Type. -Variable S : A -> Type. -Variable Seq : forall {a:A}, relation (S a). - -Hypothesis Seq_refl : forall {a:A} (x : S a), Seq x x. -Hypothesis Seq_sym : forall {a:A} (x y : S a), Seq x y -> Seq y x. -Hypothesis Seq_trans : forall {a:A} (x y z : S a), Seq x y -> Seq y z -> -Seq x z. - -Add Parametric Relation a : (S a) Seq - reflexivity proved by Seq_refl - symmetry proved by Seq_sym - transitivity proved by Seq_trans - as S_Setoid. - -Goal forall (a : A) (x y : S a), Seq x y -> Seq x y. - intros a x y H. - setoid_replace x with y. - reflexivity. - trivial. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1643.v b/test-suite/bugs/closed/shouldsucceed/1643.v deleted file mode 100644 index 879a65b1..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1643.v +++ /dev/null @@ -1,20 +0,0 @@ -(* Check some aspects of that the algorithm used to possibly reuse a - global name in the recursive calls (coinductive case) *) - -CoInductive Str : Set := Cons (h:nat) (t:Str). - -Definition decomp_func (s:Str) := - match s with - | Cons h t => Cons h t - end. - -Theorem decomp s: s = decomp_func s. -Proof. - case s; simpl; reflexivity. -Qed. - -Definition zeros := (cofix z : Str := Cons 0 z). -Lemma zeros_rw : zeros = Cons 0 zeros. - rewrite (decomp zeros). - simpl. -Admitted. diff --git a/test-suite/bugs/closed/shouldsucceed/1680.v b/test-suite/bugs/closed/shouldsucceed/1680.v deleted file mode 100644 index 524c7bab..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1680.v +++ /dev/null @@ -1,9 +0,0 @@ -Ltac int1 := let h := fresh in intro h. - -Goal nat -> nat -> True. - let h' := fresh in (let h := fresh in intro h); intro h'. - Restart. let h' := fresh in int1; intro h'. - trivial. -Qed. - - diff --git a/test-suite/bugs/closed/shouldsucceed/1683.v b/test-suite/bugs/closed/shouldsucceed/1683.v deleted file mode 100644 index 3e99694b..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1683.v +++ /dev/null @@ -1,42 +0,0 @@ -Require Import Setoid. - -Section SetoidBug. - -Variable ms : Type. -Variable ms_type : ms -> Type. -Variable ms_eq : forall (A:ms), relation (ms_type A). - -Variable CR : ms. - -Record Ring : Type := -{Ring_type : Type}. - -Variable foo : forall (A:Ring), nat -> Ring_type A. -Variable IR : Ring. -Variable IRasCR : Ring_type IR -> ms_type CR. - -Definition CRasCRing : Ring := Build_Ring (ms_type CR). - -Hypothesis ms_refl : forall A x, ms_eq A x x. -Hypothesis ms_sym : forall A x y, ms_eq A x y -> ms_eq A y x. -Hypothesis ms_trans : forall A x y z, ms_eq A x y -> ms_eq A y z -> ms_eq A x z. - -Add Parametric Relation A : (ms_type A) (ms_eq A) - reflexivity proved by (ms_refl A) - symmetry proved by (ms_sym A) - transitivity proved by (ms_trans A) - as ms_Setoid. - -Hypothesis foobar : forall n, ms_eq CR (IRasCR (foo IR n)) (foo CRasCRing n). - -Goal forall (b:ms_type CR), - ms_eq CR (IRasCR (foo IR O)) b -> - ms_eq CR (IRasCR (foo IR O)) b. -intros b H. -rewrite foobar. -rewrite foobar in H. -assumption. -Qed. - - - diff --git a/test-suite/bugs/closed/shouldsucceed/1696.v b/test-suite/bugs/closed/shouldsucceed/1696.v deleted file mode 100644 index 0826428a..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1696.v +++ /dev/null @@ -1,16 +0,0 @@ -Require Import Setoid. - -Inductive mynat := z : mynat | s : mynat -> mynat. - -Parameter E : mynat -> mynat -> Prop. -Axiom E_equiv : equiv mynat E. - -Add Relation mynat E - reflexivity proved by (proj1 E_equiv) - symmetry proved by (proj2 (proj2 E_equiv)) - transitivity proved by (proj1 (proj2 E_equiv)) -as E_rel. - -Notation "x == y" := (E x y) (at level 70). - -Goal z == s z -> s z == z. intros H. setoid_rewrite H at 2. reflexivity. Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1704.v b/test-suite/bugs/closed/shouldsucceed/1704.v deleted file mode 100644 index 4b02d5f9..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1704.v +++ /dev/null @@ -1,17 +0,0 @@ - -Require Import Setoid. -Parameter E : nat -> nat -> Prop. -Axiom E_equiv : equiv nat E. -Add Relation nat E -reflexivity proved by (proj1 E_equiv) -symmetry proved by (proj2 (proj2 E_equiv)) -transitivity proved by (proj1 (proj2 E_equiv)) -as E_rel. -Notation "x == y" := (E x y) (at level 70, no associativity). -Axiom r : False -> 0 == 1. -Goal 0 == 0. -Proof. -rewrite r. -reflexivity. -admit. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1711.v b/test-suite/bugs/closed/shouldsucceed/1711.v deleted file mode 100644 index e16612e3..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1711.v +++ /dev/null @@ -1,34 +0,0 @@ -(* Test for evar map consistency - was failing at some point and was *) -(* assumed to be solved from revision 10151 (but using a bad fix) *) - -Require Import List. -Set Implicit Arguments. - -Inductive rose : Set := Rose : nat -> list rose -> rose. - -Section RoseRec. -Variables (P: rose -> Set)(L: list rose -> Set). -Hypothesis - (R: forall n rs, L rs -> P (Rose n rs)) - (Lnil: L nil) - (Lcons: forall r rs, P r -> L rs -> L (cons r rs)). - -Fixpoint rose_rec2 (t:rose) {struct t} : P t := - match t as x return P x with - | Rose n rs => - R n ((fix rs_ind (l' : list rose): L l' := - match l' as x return L x with - | nil => Lnil - | cons t tl => Lcons (rose_rec2 t) (rs_ind tl) - end) - rs) - end. -End RoseRec. - -Lemma rose_map : rose -> rose. -Proof. intro H; elim H using rose_rec2 with - (L:=fun _ => list rose); (* was assumed to fail here *) -(* (L:=fun (_:list rose) => list rose); *) - clear H; simpl; intros. - exact (Rose n rs). exact nil. exact (H::H0). -Defined. diff --git a/test-suite/bugs/closed/shouldsucceed/1718.v b/test-suite/bugs/closed/shouldsucceed/1718.v deleted file mode 100644 index 715fa941..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1718.v +++ /dev/null @@ -1,9 +0,0 @@ -(* lazy delta unfolding used to miss delta on rels and vars (fixed in 10172) *) - -Check - let g := fun _ => 0 in - fix f (n : nat) := - match n with - | 0 => g f - | S n' => 0 - end. diff --git a/test-suite/bugs/closed/shouldsucceed/1738.v b/test-suite/bugs/closed/shouldsucceed/1738.v deleted file mode 100644 index c2926a2b..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1738.v +++ /dev/null @@ -1,30 +0,0 @@ -Require Import FSets. - -Module SomeSetoids (Import M:FSetInterface.S). - -Lemma Equal_refl : forall s, s[=]s. -Proof. red; split; auto. Qed. - -Add Relation t Equal - reflexivity proved by Equal_refl - symmetry proved by eq_sym - transitivity proved by eq_trans - as EqualSetoid. - -Add Morphism Empty with signature Equal ==> iff as Empty_m. -Proof. -unfold Equal, Empty; firstorder. -Qed. - -End SomeSetoids. - -Module Test (Import M:FSetInterface.S). - Module A:=SomeSetoids M. - Module B:=SomeSetoids M. (* lots of warning *) - - Lemma Test : forall s s', s[=]s' -> Empty s -> Empty s'. - intros. - rewrite H in H0. - assumption. -Qed. -End Test. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1740.v b/test-suite/bugs/closed/shouldsucceed/1740.v deleted file mode 100644 index ec4a7a6b..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1740.v +++ /dev/null @@ -1,23 +0,0 @@ -(* Check that expansion of alias in pattern-matching compilation is no - longer dependent of whether the pattern-matching problem occurs in a - typed context or at toplevel (solved from revision 10883) *) - -Definition f := - fun n m : nat => - match n, m with - | O, _ => O - | n, O => n - | _, _ => O - end. - -Goal f = - fun n m : nat => - match n, m with - | O, _ => O - | n, O => n - | _, _ => O - end. - unfold f. - reflexivity. -Qed. - diff --git a/test-suite/bugs/closed/shouldsucceed/1754.v b/test-suite/bugs/closed/shouldsucceed/1754.v deleted file mode 100644 index 06b8dce8..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1754.v +++ /dev/null @@ -1,24 +0,0 @@ -Axiom hp : Set. -Axiom cont : nat -> hp -> Prop. -Axiom sconj : (hp -> Prop) -> (hp -> Prop) -> hp -> Prop. -Axiom sconjImpl : forall h A B, - (sconj A B) h -> forall (A' B': hp -> Prop), - (forall h', A h' -> A' h') -> - (forall h', B h' -> B' h') -> - (sconj A' B') h. - -Definition cont' (h:hp) := exists y, cont y h. - -Lemma foo : forall h x y A, - (sconj (cont x) (sconj (cont y) A)) h -> - (sconj cont' (sconj cont' A)) h. -Proof. - intros h x y A H. - eapply sconjImpl. - 2:intros h' Hp'; econstructor; apply Hp'. - 2:intros h' Hp'; eapply sconjImpl. - 3:intros h'' Hp''; econstructor; apply Hp''. - 3:intros h'' Hp''; apply Hp''. - 2:apply Hp'. - clear H. -Admitted. diff --git a/test-suite/bugs/closed/shouldsucceed/1773.v b/test-suite/bugs/closed/shouldsucceed/1773.v deleted file mode 100644 index 211af89b..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1773.v +++ /dev/null @@ -1,9 +0,0 @@ -(* An occur-check test was done too early *) - -Goal forall B C : nat -> nat -> Prop, forall k, - (exists A, (forall k', C A k' -> B A k') -> B A k). -Proof. - intros B C k. - econstructor. - intros X. - apply X. (* used to fail here *) diff --git a/test-suite/bugs/closed/shouldsucceed/1774.v b/test-suite/bugs/closed/shouldsucceed/1774.v deleted file mode 100644 index 4c24b481..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1774.v +++ /dev/null @@ -1,18 +0,0 @@ -Axiom pl : (nat -> Prop) -> (nat -> Prop) -> (nat -> Prop). -Axiom plImp : forall k P Q, - pl P Q k -> forall (P':nat -> Prop), - (forall k', P k' -> P' k') -> forall (Q':nat -> Prop), - (forall k', Q k' -> Q' k') -> - pl P' Q' k. - -Definition nexists (P:nat -> nat -> Prop) : nat -> Prop := - fun k' => exists k, P k k'. - -Goal forall k (A:nat -> nat -> Prop) (B:nat -> Prop), - pl (nexists A) B k. -intros. -eapply plImp. -2:intros m' M'; econstructor; apply M'. -2:intros m' M'; apply M'. -simpl. -Admitted. diff --git a/test-suite/bugs/closed/shouldsucceed/1775.v b/test-suite/bugs/closed/shouldsucceed/1775.v deleted file mode 100644 index 932949a3..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1775.v +++ /dev/null @@ -1,39 +0,0 @@ -Axiom pair : nat -> nat -> nat -> Prop. -Axiom pl : (nat -> Prop) -> (nat -> Prop) -> (nat -> Prop). -Axiom plImp : forall k P Q, - pl P Q k -> forall (P':nat -> Prop), - (forall k', P k' -> P' k') -> forall (Q':nat -> Prop), - (forall k', Q k' -> Q' k') -> - pl P' Q' k. - -Definition nexists (P:nat -> nat -> Prop) : nat -> Prop := - fun k' => exists k, P k k'. - -Goal forall s k k' m, - (pl k' (nexists (fun w => (nexists (fun b => pl (pair w w) - (pl (pair s b) - (nexists (fun w0 => (nexists (fun a => pl (pair b w0) - (nexists (fun w1 => (nexists (fun c => pl - (pair a w1) (pl (pair a c) k))))))))))))))) m. -intros. -eapply plImp; [ | eauto | intros ]. -2:econstructor. -2:econstructor. -2:eapply plImp; [ | eauto | intros ]. -3:eapply plImp; [ | eauto | intros ]. -4:econstructor. -4:econstructor. -4:eapply plImp; [ | eauto | intros ]. -5:econstructor. -5:econstructor. -5:eauto. -4:eauto. -3:eauto. -2:eauto. - -assert (X := 1). -clear X. (* very slow! *) - -simpl. (* exception Not_found *) - -Admitted. diff --git a/test-suite/bugs/closed/shouldsucceed/1776.v b/test-suite/bugs/closed/shouldsucceed/1776.v deleted file mode 100644 index 58491f9d..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1776.v +++ /dev/null @@ -1,22 +0,0 @@ -Axiom pair : nat -> nat -> nat -> Prop. -Axiom pl : (nat -> Prop) -> (nat -> Prop) -> (nat -> Prop). -Axiom plImpR : forall k P Q, - pl P Q k -> forall (Q':nat -> Prop), - (forall k', Q k' -> Q' k') -> - pl P Q' k. - -Definition nexists (P:nat -> nat -> Prop) : nat -> Prop := - fun k' => exists k, P k k'. - -Goal forall a A m, - True -> - (pl A (nexists (fun x => (nexists - (fun y => pl (pair a (S x)) (pair a (S y))))))) m. -Proof. - intros. - eapply plImpR; [ | intros; econstructor; econstructor; eauto]. - clear H; - match goal with - | |- (pl _ (pl (pair _ ?x) _)) _ => replace x with 0 - end. -Admitted. diff --git a/test-suite/bugs/closed/shouldsucceed/1779.v b/test-suite/bugs/closed/shouldsucceed/1779.v deleted file mode 100644 index 95bb66b9..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1779.v +++ /dev/null @@ -1,25 +0,0 @@ -Require Import Div2. - -Lemma double_div2: forall n, div2 (double n) = n. -exact (fun n => let _subcase := - let _cofact := fun _ : 0 = 0 => refl_equal 0 in - _cofact (let _fact := refl_equal 0 in _fact) in - let _subcase0 := - fun (m : nat) (Hrec : div2 (double m) = m) => - let _fact := f_equal div2 (double_S m) in - let _eq := trans_eq _fact (refl_equal (S (div2 (double m)))) in - let _eq0 := - trans_eq _eq - (trans_eq - (f_equal (fun f : nat -> nat => f (div2 (double m))) - (refl_equal S)) (f_equal S Hrec)) in - _eq0 in - (fix _fix (__ : nat) : div2 (double __) = __ := - match __ as n return (div2 (double n) = n) with - | 0 => _subcase - | S __0 => - (fun _hrec : div2 (double __0) = __0 => _subcase0 __0 _hrec) - (_fix __0) - end) n). -Guarded. -Defined. diff --git a/test-suite/bugs/closed/shouldsucceed/1784.v b/test-suite/bugs/closed/shouldsucceed/1784.v deleted file mode 100644 index fb2f0ca9..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1784.v +++ /dev/null @@ -1,101 +0,0 @@ -Require Import List. -Require Import ZArith. -Require String. Open Scope string_scope. -Ltac Case s := let c := fresh "case" in set (c := s). - -Set Implicit Arguments. -Unset Strict Implicit. - -Inductive sv : Set := -| I : Z -> sv -| S : list sv -> sv. - -Section sv_induction. - -Variables - (VP: sv -> Prop) - (LP: list sv -> Prop) - - (VPint: forall n, VP (I n)) - (VPset: forall vs, LP vs -> VP (S vs)) - (lpcons: forall v vs, VP v -> LP vs -> LP (v::vs)) - (lpnil: LP nil). - -Fixpoint setl_value_indp (x:sv) {struct x}: VP x := - match x as x return VP x with - | I n => VPint n - | S vs => - VPset - ((fix values_indp (vs:list sv) {struct vs}: (LP vs) := - match vs as vs return LP vs with - | nil => lpnil - | v::vs => lpcons (setl_value_indp v) (values_indp vs) - end) vs) - end. -End sv_induction. - -Inductive slt : sv -> sv -> Prop := -| IC : forall z, slt (I z) (I z) -| IS : forall vs vs', slist_in vs vs' -> slt (S vs) (S vs') - -with sin : sv -> list sv -> Prop := -| Ihd : forall s s' sv', slt s s' -> sin s (s'::sv') -| Itl : forall s s' sv', sin s sv' -> sin s (s'::sv') - -with slist_in : list sv -> list sv -> Prop := -| Inil : forall sv', - slist_in nil sv' -| Icons : forall s sv sv', - sin s sv' -> - slist_in sv sv' -> - slist_in (s::sv) sv'. - -Hint Constructors sin slt slist_in. - -Require Import Program. - -Program Fixpoint lt_dec (x y:sv) { struct x } : {slt x y}+{~slt x y} := - match x with - | I x => - match y with - | I y => if (Z.eq_dec x y) then in_left else in_right - | S ys => in_right - end - | S xs => - match y with - | I y => in_right - | S ys => - let fix list_in (xs ys:list sv) {struct xs} : - {slist_in xs ys} + {~slist_in xs ys} := - match xs with - | nil => in_left - | x::xs => - let fix elem_in (ys:list sv) : {sin x ys}+{~sin x ys} := - match ys with - | nil => in_right - | y::ys => if lt_dec x y then in_left else if elem_in - ys then in_left else in_right - end - in - if elem_in ys then - if list_in xs ys then in_left else in_right - else in_right - end - in if list_in xs ys then in_left else in_right - end - end. - -Next Obligation. intro H0. apply H; inversion H0; subst; trivial. Defined. -Next Obligation. intro H; inversion H. Defined. -Next Obligation. intro H; inversion H. Defined. -Next Obligation. intro H; inversion H; subst. Defined. -Next Obligation. - intro H1; contradict H. inversion H1; subst. assumption. - contradict H0; assumption. Defined. -Next Obligation. - intro H1; contradict H0. inversion H1; subst. assumption. Defined. -Next Obligation. - intro H1; contradict H. inversion H1; subst. assumption. Defined. -Next Obligation. - intro H0; contradict H. inversion H0; subst; auto. Defined. - diff --git a/test-suite/bugs/closed/shouldsucceed/1791.v b/test-suite/bugs/closed/shouldsucceed/1791.v deleted file mode 100644 index be0e8ae8..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1791.v +++ /dev/null @@ -1,38 +0,0 @@ -(* simpl performs eta expansion *) - -Set Implicit Arguments. -Require Import List. - -Definition k0 := Set. -Definition k1 := k0 -> k0. - -(** iterating X n times *) -Fixpoint Pow (X:k1)(k:nat){struct k}:k1:= - match k with 0 => fun X => X - | S k' => fun A => X (Pow X k' A) - end. - -Parameter Bush: k1. -Parameter BushToList: forall (A:k0), Bush A -> list A. - -Definition BushnToList (n:nat)(A:k0)(t:Pow Bush n A): list A. -Proof. - intros. - induction n. - exact (t::nil). - simpl in t. - exact (flat_map IHn (BushToList t)). -Defined. - -Parameter bnil : forall (A:k0), Bush A. -Axiom BushToList_bnil: forall (A:k0), BushToList (bnil A) = nil(A:=A). - -Lemma BushnToList_bnil (n:nat)(A:k0): - BushnToList (S n) A (bnil (Pow Bush n A)) = nil. -Proof. - intros. - simpl. - rewrite BushToList_bnil. - simpl. - reflexivity. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1834.v b/test-suite/bugs/closed/shouldsucceed/1834.v deleted file mode 100644 index 947d15f0..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1834.v +++ /dev/null @@ -1,174 +0,0 @@ -(* This tests rather deep nesting of abstracted terms *) - -(* This used to fail before Nov 2011 because of a de Bruijn indice bug - in extract_predicate. - - Note: use of eq_ok allows shorten notations but was not in the - original example -*) - -Scheme eq_rec_dep := Induction for eq Sort Type. - -Section Teq. - -Variable P0: Type. -Variable P1: forall (y0:P0), Type. -Variable P2: forall y0 (y1:P1 y0), Type. -Variable P3: forall y0 y1 (y2:P2 y0 y1), Type. -Variable P4: forall y0 y1 y2 (y3:P3 y0 y1 y2), Type. -Variable P5: forall y0 y1 y2 y3 (y4:P4 y0 y1 y2 y3), Type. - -Variable x0:P0. - -Inductive eq0 : P0 -> Prop := - refl0: eq0 x0. - -Definition eq_0 y0 := x0 = y0. - -Variable x1:P1 x0. - -Inductive eq1 : forall y0, P1 y0 -> Prop := - refl1: eq1 x0 x1. - -Definition S0_0 y0 (e0:eq_0 y0) := - eq_rec_dep P0 x0 (fun y0 e0 => P1 y0) x1 y0 e0. - -Definition eq_ok0 y0 y1 (E: eq_0 y0) := S0_0 y0 E = y1. - -Definition eq_1 y0 y1 := - {E0:eq_0 y0 | eq_ok0 y0 y1 E0}. - -Variable x2:P2 x0 x1. - -Inductive eq2 : -forall y0 y1, P2 y0 y1 -> Prop := -refl2: eq2 x0 x1 x2. - -Definition S1_0 y0 (e0:eq_0 y0) := -eq_rec_dep P0 x0 (fun y0 e0 => P2 y0 (S0_0 y0 e0)) x2 y0 e0. - -Definition S1_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := - eq_rec_dep (P1 y0) (S0_0 y0 e0) (fun y1 e1 => P2 y0 y1) - (S1_0 y0 e0) - y1 e1. - -Definition eq_ok1 y0 y1 y2 (E: eq_1 y0 y1) := - match E with exist e0 e1 => S1_1 y0 y1 e0 e1 = y2 end. - -Definition eq_2 y0 y1 y2 := - {E1:eq_1 y0 y1 | eq_ok1 y0 y1 y2 E1}. - -Variable x3:P3 x0 x1 x2. - -Inductive eq3 : -forall y0 y1 y2, P3 y0 y1 y2 -> Prop := -refl3: eq3 x0 x1 x2 x3. - -Definition S2_0 y0 (e0:eq_0 y0) := -eq_rec_dep P0 x0 (fun y0 e0 => P3 y0 (S0_0 y0 e0) (S1_0 y0 e0)) x3 y0 e0. - -Definition S2_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := - eq_rec_dep (P1 y0) (S0_0 y0 e0) - (fun y1 e1 => P3 y0 y1 (S1_1 y0 y1 e0 e1)) - (S2_0 y0 e0) - y1 e1. - -Definition S2_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) - (e2:S1_1 y0 y1 e0 e1 = y2) := - eq_rec_dep (P2 y0 y1) (S1_1 y0 y1 e0 e1) - (fun y2 e2 => P3 y0 y1 y2) - (S2_1 y0 y1 e0 e1) - y2 e2. - -Definition eq_ok2 y0 y1 y2 y3 (E: eq_2 y0 y1 y2) : Prop := - match E with exist (exist e0 e1) e2 => - S2_2 y0 y1 y2 e0 e1 e2 = y3 end. - -Definition eq_3 y0 y1 y2 y3 := - {E2: eq_2 y0 y1 y2 | eq_ok2 y0 y1 y2 y3 E2}. - -Variable x4:P4 x0 x1 x2 x3. - -Inductive eq4 : -forall y0 y1 y2 y3, P4 y0 y1 y2 y3 -> Prop := -refl4: eq4 x0 x1 x2 x3 x4. - -Definition S3_0 y0 (e0:eq_0 y0) := -eq_rec_dep P0 x0 (fun y0 e0 => P4 y0 (S0_0 y0 e0) (S1_0 y0 e0) (S2_0 y0 e0)) - x4 y0 e0. - -Definition S3_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := - eq_rec_dep (P1 y0) (S0_0 y0 e0) - (fun y1 e1 => P4 y0 y1 (S1_1 y0 y1 e0 e1) (S2_1 y0 y1 e0 e1)) - (S3_0 y0 e0) - y1 e1. - -Definition S3_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) - (e2:S1_1 y0 y1 e0 e1 = y2) := - eq_rec_dep (P2 y0 y1) (S1_1 y0 y1 e0 e1) - (fun y2 e2 => P4 y0 y1 y2 (S2_2 y0 y1 y2 e0 e1 e2)) - (S3_1 y0 y1 e0 e1) - y2 e2. - -Definition S3_3 y0 y1 y2 y3 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) - (e2:S1_1 y0 y1 e0 e1 = y2) (e3:S2_2 y0 y1 y2 e0 e1 e2 = y3):= - eq_rec_dep (P3 y0 y1 y2) (S2_2 y0 y1 y2 e0 e1 e2) - (fun y3 e3 => P4 y0 y1 y2 y3) - (S3_2 y0 y1 y2 e0 e1 e2) - y3 e3. - -Definition eq_ok3 y0 y1 y2 y3 y4 (E: eq_3 y0 y1 y2 y3) : Prop := - match E with exist (exist (exist e0 e1) e2) e3 => - S3_3 y0 y1 y2 y3 e0 e1 e2 e3 = y4 end. - -Definition eq_4 y0 y1 y2 y3 y4 := - {E3: eq_3 y0 y1 y2 y3 | eq_ok3 y0 y1 y2 y3 y4 E3}. - -Variable x5:P5 x0 x1 x2 x3 x4. - -Inductive eq5 : -forall y0 y1 y2 y3 y4, P5 y0 y1 y2 y3 y4 -> Prop := -refl5: eq5 x0 x1 x2 x3 x4 x5. - -Definition S4_0 y0 (e0:eq_0 y0) := -eq_rec_dep P0 x0 -(fun y0 e0 => P5 y0 (S0_0 y0 e0) (S1_0 y0 e0) (S2_0 y0 e0) (S3_0 y0 e0)) - x5 y0 e0. - -Definition S4_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := - eq_rec_dep (P1 y0) (S0_0 y0 e0) - (fun y1 e1 => P5 y0 y1 (S1_1 y0 y1 e0 e1) (S2_1 y0 y1 e0 e1) (S3_1 y0 y1 e0 -e1)) - (S4_0 y0 e0) - y1 e1. - -Definition S4_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) - (e2:S1_1 y0 y1 e0 e1 = y2) := - eq_rec_dep (P2 y0 y1) (S1_1 y0 y1 e0 e1) - (fun y2 e2 => P5 y0 y1 y2 (S2_2 y0 y1 y2 e0 e1 e2) (S3_2 y0 y1 y2 e0 e1 e2)) - (S4_1 y0 y1 e0 e1) - y2 e2. - -Definition S4_3 y0 y1 y2 y3 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) - (e2:S1_1 y0 y1 e0 e1 = y2) (e3:S2_2 y0 y1 y2 e0 e1 e2 = y3):= - eq_rec_dep (P3 y0 y1 y2) (S2_2 y0 y1 y2 e0 e1 e2) - (fun y3 e3 => P5 y0 y1 y2 y3 (S3_3 y0 y1 y2 y3 e0 e1 e2 e3)) - (S4_2 y0 y1 y2 e0 e1 e2) - y3 e3. - -Definition S4_4 y0 y1 y2 y3 y4 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) - (e2:S1_1 y0 y1 e0 e1 = y2) (e3:S2_2 y0 y1 y2 e0 e1 e2 = y3) - (e4:S3_3 y0 y1 y2 y3 e0 e1 e2 e3 = y4) := - eq_rec_dep (P4 y0 y1 y2 y3) (S3_3 y0 y1 y2 y3 e0 e1 e2 e3) - (fun y4 e4 => P5 y0 y1 y2 y3 y4) - (S4_3 y0 y1 y2 y3 e0 e1 e2 e3) - y4 e4. - -Definition eq_ok4 y0 y1 y2 y3 y4 y5 (E: eq_4 y0 y1 y2 y3 y4) : Prop := - match E with exist (exist (exist (exist e0 e1) e2) e3) e4 => - S4_4 y0 y1 y2 y3 y4 e0 e1 e2 e3 e4 = y5 end. - -Definition eq_5 y0 y1 y2 y3 y4 y5 := - {E4: eq_4 y0 y1 y2 y3 y4 | eq_ok4 y0 y1 y2 y3 y4 y5 E4 }. - -End Teq. diff --git a/test-suite/bugs/closed/shouldsucceed/1844.v b/test-suite/bugs/closed/shouldsucceed/1844.v deleted file mode 100644 index 17eeb352..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1844.v +++ /dev/null @@ -1,217 +0,0 @@ -Require Import ZArith. - -Definition zeq := Z.eq_dec. - -Definition update (A: Set) (x: Z) (v: A) (s: Z -> A) : Z -> A := - fun y => if zeq x y then v else s y. - -Implicit Arguments update [A]. - -Definition ident := Z. -Parameter operator: Set. -Parameter value: Set. -Parameter is_true: value -> Prop. -Definition label := Z. - -Inductive expr : Set := - | Evar: ident -> expr - | Econst: value -> expr - | Eop: operator -> expr -> expr -> expr. - -Inductive stmt : Set := - | Sskip: stmt - | Sassign: ident -> expr -> stmt - | Scall: ident -> ident -> expr -> stmt (* x := f(e) *) - | Sreturn: expr -> stmt - | Sseq: stmt -> stmt -> stmt - | Sifthenelse: expr -> stmt -> stmt -> stmt - | Sloop: stmt -> stmt - | Sblock: stmt -> stmt - | Sexit: nat -> stmt - | Slabel: label -> stmt -> stmt - | Sgoto: label -> stmt. - -Record function : Set := mkfunction { - fn_param: ident; - fn_body: stmt -}. - -Parameter program: ident -> option function. - -Parameter main_function: ident. - -Definition store := ident -> value. - -Parameter empty_store : store. - -Parameter eval_op: operator -> value -> value -> option value. - -Fixpoint eval_expr (st: store) (e: expr) {struct e} : option value := - match e with - | Evar v => Some (st v) - | Econst v => Some v - | Eop op e1 e2 => - match eval_expr st e1, eval_expr st e2 with - | Some v1, Some v2 => eval_op op v1 v2 - | _, _ => None - end - end. - -Inductive outcome: Set := - | Onormal: outcome - | Oexit: nat -> outcome - | Ogoto: label -> outcome - | Oreturn: value -> outcome. - -Definition outcome_block (out: outcome) : outcome := - match out with - | Onormal => Onormal - | Oexit O => Onormal - | Oexit (S m) => Oexit m - | Ogoto lbl => Ogoto lbl - | Oreturn v => Oreturn v - end. - -Fixpoint label_defined (lbl: label) (s: stmt) {struct s}: Prop := - match s with - | Sskip => False - | Sassign id e => False - | Scall id fn e => False - | Sreturn e => False - | Sseq s1 s2 => label_defined lbl s1 \/ label_defined lbl s2 - | Sifthenelse e s1 s2 => label_defined lbl s1 \/ label_defined lbl s2 - | Sloop s1 => label_defined lbl s1 - | Sblock s1 => label_defined lbl s1 - | Sexit n => False - | Slabel lbl1 s1 => lbl1 = lbl \/ label_defined lbl s1 - | Sgoto lbl => False - end. - -Inductive exec : stmt -> store -> outcome -> store -> Prop := - | exec_skip: forall st, - exec Sskip st Onormal st - | exec_assign: forall id e st v, - eval_expr st e = Some v -> - exec (Sassign id e) st Onormal (update id v st) - | exec_call: forall id fn e st v1 f v2 st', - eval_expr st e = Some v1 -> - program fn = Some f -> - exec_function f (update f.(fn_param) v1 empty_store) v2 st' -> - exec (Scall id fn e) st Onormal (update id v2 st) - | exec_return: forall e st v, - eval_expr st e = Some v -> - exec (Sreturn e) st (Oreturn v) st - | exec_seq_2: forall s1 s2 st st1 out' st', - exec s1 st Onormal st1 -> exec s2 st1 out' st' -> - exec (Sseq s1 s2) st out' st' - | exec_seq_1: forall s1 s2 st out st', - exec s1 st out st' -> out <> Onormal -> - exec (Sseq s1 s2) st out st' - | exec_ifthenelse_true: forall e s1 s2 st out st' v, - eval_expr st e = Some v -> is_true v -> exec s1 st out st' -> - exec (Sifthenelse e s1 s2) st out st' - | exec_ifthenelse_false: forall e s1 s2 st out st' v, - eval_expr st e = Some v -> ~is_true v -> exec s2 st out st' -> - exec (Sifthenelse e s1 s2) st out st' - | exec_loop_loop: forall s st st1 out' st', - exec s st Onormal st1 -> - exec (Sloop s) st1 out' st' -> - exec (Sloop s) st out' st' - | exec_loop_stop: forall s st st' out, - exec s st out st' -> out <> Onormal -> - exec (Sloop s) st out st' - | exec_block: forall s st out st', - exec s st out st' -> - exec (Sblock s) st (outcome_block out) st' - | exec_exit: forall n st, - exec (Sexit n) st (Oexit n) st - | exec_label: forall s lbl st st' out, - exec s st out st' -> - exec (Slabel lbl s) st out st' - | exec_goto: forall st lbl, - exec (Sgoto lbl) st (Ogoto lbl) st - -(** [execg lbl stmt st out st'] starts executing at label [lbl] within [s], - in initial store [st]. The result of the execution is the outcome - [out] with final store [st']. *) - -with execg: label -> stmt -> store -> outcome -> store -> Prop := - | execg_left_seq_2: forall lbl s1 s2 st st1 out' st', - execg lbl s1 st Onormal st1 -> exec s2 st1 out' st' -> - execg lbl (Sseq s1 s2) st out' st' - | execg_left_seq_1: forall lbl s1 s2 st out st', - execg lbl s1 st out st' -> out <> Onormal -> - execg lbl (Sseq s1 s2) st out st' - | execg_right_seq: forall lbl s1 s2 st out st', - ~(label_defined lbl s1) -> - execg lbl s2 st out st' -> - execg lbl (Sseq s1 s2) st out st' - | execg_ifthenelse_left: forall lbl e s1 s2 st out st', - execg lbl s1 st out st' -> - execg lbl (Sifthenelse e s1 s2) st out st' - | execg_ifthenelse_right: forall lbl e s1 s2 st out st', - ~(label_defined lbl s1) -> - execg lbl s2 st out st' -> - execg lbl (Sifthenelse e s1 s2) st out st' - | execg_loop_loop: forall lbl s st st1 out' st', - execg lbl s st Onormal st1 -> - exec (Sloop s) st1 out' st' -> - execg lbl (Sloop s) st out' st' - | execg_loop_stop: forall lbl s st st' out, - execg lbl s st out st' -> out <> Onormal -> - execg lbl (Sloop s) st out st' - | execg_block: forall lbl s st out st', - execg lbl s st out st' -> - execg lbl (Sblock s) st (outcome_block out) st' - | execg_label_found: forall lbl s st st' out, - exec s st out st' -> - execg lbl (Slabel lbl s) st out st' - | execg_label_notfound: forall lbl s lbl' st st' out, - lbl' <> lbl -> - execg lbl s st out st' -> - execg lbl (Slabel lbl' s) st out st' - -(** [exec_finish out st st'] takes the outcome [out] and the store [st] - at the end of the evaluation of the program. If [out] is a [goto], - execute again the program starting at the corresponding label. - Iterate this way until [out] is [Onormal]. *) - -with exec_finish: function -> outcome -> store -> value -> store -> Prop := - | exec_finish_normal: forall f st v, - exec_finish f (Oreturn v) st v st - | exec_finish_goto: forall f lbl st out v st1 st', - execg lbl f.(fn_body) st out st1 -> - exec_finish f out st1 v st' -> - exec_finish f (Ogoto lbl) st v st' - -(** Execution of a function *) - -with exec_function: function -> store -> value -> store -> Prop := - | exec_function_intro: forall f st out st1 v st', - exec f.(fn_body) st out st1 -> - exec_finish f out st1 v st' -> - exec_function f st v st'. - -Scheme exec_ind4:= Minimality for exec Sort Prop - with execg_ind4:= Minimality for execg Sort Prop - with exec_finish_ind4 := Minimality for exec_finish Sort Prop - with exec_function_ind4 := Minimality for exec_function Sort Prop. - -Scheme exec_dind4:= Induction for exec Sort Prop - with execg_dind4:= Minimality for execg Sort Prop - with exec_finish_dind4 := Induction for exec_finish Sort Prop - with exec_function_dind4 := Induction for exec_function Sort Prop. - -Combined Scheme exec_inductiond from exec_dind4, execg_dind4, exec_finish_dind4, - exec_function_dind4. - -Scheme exec_dind4' := Induction for exec Sort Prop - with execg_dind4' := Induction for execg Sort Prop - with exec_finish_dind4' := Induction for exec_finish Sort Prop - with exec_function_dind4' := Induction for exec_function Sort Prop. - -Combined Scheme exec_induction from exec_ind4, execg_ind4, exec_finish_ind4, - exec_function_ind4. - -Combined Scheme exec_inductiond' from exec_dind4', execg_dind4', exec_finish_dind4', - exec_function_dind4'. diff --git a/test-suite/bugs/closed/shouldsucceed/1865.v b/test-suite/bugs/closed/shouldsucceed/1865.v deleted file mode 100644 index 17c19989..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1865.v +++ /dev/null @@ -1,18 +0,0 @@ -(* Check that tactics (here dependent inversion) do not generate - conversion problems T <= U with sup's of universes in U *) - -(* Submitted by David Nowak *) - -Inductive list (A:Set) : nat -> Set := -| nil : list A O -| cons : forall n, A -> list A n -> list A (S n). - -Definition f (n:nat) : Type := - match n with - | O => bool - | _ => unit - end. - -Goal forall A n, list A n -> f n. -intros A n. -dependent inversion n. diff --git a/test-suite/bugs/closed/shouldsucceed/1891.v b/test-suite/bugs/closed/shouldsucceed/1891.v deleted file mode 100644 index 2d90a2f1..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1891.v +++ /dev/null @@ -1,13 +0,0 @@ -(* Check evar-evar unification *) - Inductive T (A: Set): Set := mkT: unit -> T A. - - Definition f (A: Set) (l: T A): unit := tt. - - Implicit Arguments f [A]. - - Lemma L (x: T unit): (unit -> T unit) -> unit. - Proof. - refine (match x return _ with mkT n => fun g => f (g _) end). - trivial. - Qed. - diff --git a/test-suite/bugs/closed/shouldsucceed/1900.v b/test-suite/bugs/closed/shouldsucceed/1900.v deleted file mode 100644 index cf03efda..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1900.v +++ /dev/null @@ -1,8 +0,0 @@ -Parameter A : Type . - -Definition eq_A := @eq A. - -Goal forall x, eq_A x x. -intros. -reflexivity. -Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1901.v b/test-suite/bugs/closed/shouldsucceed/1901.v deleted file mode 100644 index 7d86adbf..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1901.v +++ /dev/null @@ -1,11 +0,0 @@ -Require Import Relations. - -Record Poset{A:Type}(Le : relation A) : Type := - Build_Poset - { - Le_refl : forall x : A, Le x x; - Le_trans : forall x y z : A, Le x y -> Le y z -> Le x z; - Le_antisym : forall x y : A, Le x y -> Le y x -> x = y }. - -Definition nat_Poset : Poset Peano.le. -Admitted. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1905.v b/test-suite/bugs/closed/shouldsucceed/1905.v deleted file mode 100644 index 8c81d751..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1905.v +++ /dev/null @@ -1,13 +0,0 @@ - -Require Import Setoid Program. - -Axiom t : Set. -Axiom In : nat -> t -> Prop. -Axiom InE : forall (x : nat) (s:t), impl (In x s) True. - -Goal forall a s, - In a s -> False. -Proof. - intros a s Ia. - rewrite InE in Ia. -Admitted. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1907.v b/test-suite/bugs/closed/shouldsucceed/1907.v deleted file mode 100644 index 55fc8231..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1907.v +++ /dev/null @@ -1,7 +0,0 @@ -(* An example of type inference *) - -Axiom A : Type. -Definition f (x y : A) := x. -Axiom g : forall x y : A, f x y = y -> Prop. -Axiom x : A. -Check (g x _ (refl_equal x)). diff --git a/test-suite/bugs/closed/shouldsucceed/1912.v b/test-suite/bugs/closed/shouldsucceed/1912.v deleted file mode 100644 index 987a5417..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1912.v +++ /dev/null @@ -1,6 +0,0 @@ -Require Import ZArith. - -Goal forall x, Z.succ (Z.pred x) = x. -intros x. -omega. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1918.v b/test-suite/bugs/closed/shouldsucceed/1918.v deleted file mode 100644 index 9d92fe12..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1918.v +++ /dev/null @@ -1,376 +0,0 @@ -(** Occur-check for Meta (up to delta) *) - -(** LNMItPredShort.v Version 2.0 July 2008 *) -(** does not need impredicative Set, runs under V8.2, tested with SVN 11296 *) - -(** Copyright Ralph Matthes, I.R.I.T., C.N.R.S. & University of Toulouse*) - - -Set Implicit Arguments. - -(** the universe of all monotypes *) -Definition k0 := Set. - -(** the type of all type transformations *) -Definition k1 := k0 -> k0. - -(** the type of all rank-2 type transformations *) -Definition k2 := k1 -> k1. - -(** polymorphic identity *) -Definition id : forall (A:Set), A -> A := fun A x => x. - -(** composition *) -Definition comp (A B C:Set)(g:B->C)(f:A->B) : A->C := fun x => g (f x). - -Infix "o" := comp (at level 90). - -Definition sub_k1 (X Y:k1) : Type := - forall A:Set, X A -> Y A. - -Infix "c_k1" := sub_k1 (at level 60). - -(** monotonicity *) -Definition mon (X:k1) : Type := forall (A B:Set), (A -> B) -> X A -> X B. - -(** extensionality *) -Definition ext (X:k1)(h: mon X): Prop := - forall (A B:Set)(f g:A -> B), - (forall a, f a = g a) -> forall r, h _ _ f r = h _ _ g r. - -(** first functor law *) -Definition fct1 (X:k1)(m: mon X) : Prop := - forall (A:Set)(x:X A), m _ _ (id(A:=A)) x = x. - -(** second functor law *) -Definition fct2 (X:k1)(m: mon X) : Prop := - forall (A B C:Set)(f:A -> B)(g:B -> C)(x:X A), - m _ _ (g o f) x = m _ _ g (m _ _ f x). - -(** pack up the good properties of the approximation into - the notion of an extensional functor *) -Record EFct (X:k1) : Type := mkEFct - { m : mon X; - e : ext m; - f1 : fct1 m; - f2 : fct2 m }. - -(** preservation of extensional functors *) -Definition pEFct (F:k2) : Type := - forall (X:k1), EFct X -> EFct (F X). - - -(** we show some closure properties of pEFct, depending on such properties - for EFct *) - -Definition moncomp (X Y:k1)(mX:mon X)(mY:mon Y): mon (fun A => X(Y A)). -Proof. - red. - intros A B f x. - exact (mX (Y A)(Y B) (mY A B f) x). -Defined. - -(** closure under composition *) -Lemma compEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X(Y A)). -Proof. - intros ef1 ef2. - apply (mkEFct(m:=moncomp (m ef1) (m ef2))); red; intros; unfold moncomp. -(* prove ext *) - apply (e ef1). - intro. - apply (e ef2); trivial. -(* prove fct1 *) - rewrite (e ef1 (m ef2 (id (A:=A))) (id(A:=Y A))). - apply (f1 ef1). - intro. - apply (f1 ef2). -(* prove fct2 *) - rewrite (e ef1 (m ef2 (g o f))((m ef2 g)o(m ef2 f))). - apply (f2 ef1). - intro. - unfold comp at 2. - apply (f2 ef2). -Defined. - -Corollary comppEFct (F G:k2): pEFct F -> pEFct G -> - pEFct (fun X A => F X (G X A)). -Proof. - red. - intros. - apply compEFct; auto. -Defined. - -(** closure under sums *) -Lemma sumEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X A + Y A)%type. -Proof. - intros ef1 ef2. - set (m12:=fun (A B:Set)(f:A->B) x => match x with - | inl y => inl _ (m ef1 f y) - | inr y => inr _ (m ef2 f y) - end). - apply (mkEFct(m:=m12)); red; intros. -(* prove ext *) - destruct r. - simpl. - apply (f_equal (fun x=>inl (A:=X B) (Y B) x)). - apply (e ef1); trivial. - simpl. - apply (f_equal (fun x=>inr (X B) (B:=Y B) x)). - apply (e ef2); trivial. -(* prove fct1 *) - destruct x. - simpl. - apply (f_equal (fun x=>inl (A:=X A) (Y A) x)). - apply (f1 ef1). - simpl. - apply (f_equal (fun x=>inr (X A) (B:=Y A) x)). - apply (f1 ef2). -(* prove fct2 *) - destruct x. - simpl. - rewrite (f2 ef1); reflexivity. - simpl. - rewrite (f2 ef2); reflexivity. -Defined. - -Corollary sumpEFct (F G:k2): pEFct F -> pEFct G -> - pEFct (fun X A => F X A + G X A)%type. -Proof. - red. - intros. - apply sumEFct; auto. -Defined. - -(** closure under products *) -Lemma prodEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X A * Y A)%type. -Proof. - intros ef1 ef2. - set (m12:=fun (A B:Set)(f:A->B) x => match x with - (x1,x2) => (m ef1 f x1, m ef2 f x2) end). - apply (mkEFct(m:=m12)); red; intros. -(* prove ext *) - destruct r as [x1 x2]. - simpl. - apply injective_projections; simpl. - apply (e ef1); trivial. - apply (e ef2); trivial. -(* prove fct1 *) - destruct x as [x1 x2]. - simpl. - apply injective_projections; simpl. - apply (f1 ef1). - apply (f1 ef2). -(* prove fct2 *) - destruct x as [x1 x2]. - simpl. - apply injective_projections; simpl. - apply (f2 ef1). - apply (f2 ef2). -Defined. - -Corollary prodpEFct (F G:k2): pEFct F -> pEFct G -> - pEFct (fun X A => F X A * G X A)%type. -Proof. - red. - intros. - apply prodEFct; auto. -Defined. - -(** the identity in k2 preserves extensional functors *) -Lemma idpEFct: pEFct (fun X => X). -Proof. - red. - intros. - assumption. -Defined. - -(** a variant for the eta-expanded identity *) -Lemma idpEFct_eta: pEFct (fun X A => X A). -Proof. - red. - intros X ef. - destruct ef as [m0 e0 f01 f02]. - change (mon X) with (mon (fun A => X A)) in m0. - apply (mkEFct (m:=m0) e0 f01 f02). -Defined. - -(** the identity in k1 "is" an extensional functor *) -Lemma idEFct: EFct (fun A => A). -Proof. - set (mId:=fun A B (f:A->B)(x:A) => f x). - apply (mkEFct(m:=mId)). - red. - intros. - unfold mId. - apply H. - red. - reflexivity. - red. - reflexivity. -Defined. - -(** constants in k2 *) -Lemma constpEFct (X:k1): EFct X -> pEFct (fun _ => X). -Proof. - red. - intros. - assumption. -Defined. - -(** constants in k1 *) -Lemma constEFct (C:Set): EFct (fun _ => C). -Proof. - set (mC:=fun A B (f:A->B)(x:C) => x). - apply (mkEFct(m:=mC)); red; intros; unfold mC; reflexivity. -Defined. - - -(** the option type *) -Lemma optionEFct: EFct (fun (A:Set) => option A). - apply (mkEFct (X:=fun (A:Set) => option A)(m:=option_map)); red; intros. - destruct r. - simpl. - rewrite H. - reflexivity. - reflexivity. - destruct x; reflexivity. - destruct x; reflexivity. -Defined. - - -(** natural transformations from (X,mX) to (Y,mY) *) -Definition NAT(X Y:k1)(j:X c_k1 Y)(mX:mon X)(mY:mon Y) : Prop := - forall (A B:Set)(f:A->B)(t:X A), j B (mX A B f t) = mY _ _ f (j A t). - - -Module Type LNMIt_Type. - -Parameter F:k2. -Parameter FpEFct: pEFct F. -Parameter mu20: k1. -Definition mu2: k1:= fun A => mu20 A. -Parameter mapmu2: mon mu2. -Definition MItType: Type := - forall G : k1, (forall X : k1, X c_k1 G -> F X c_k1 G) -> mu2 c_k1 G. -Parameter MIt0 : MItType. -Definition MIt : MItType:= fun G s A t => MIt0 s t. -Definition InType : Type := - forall (X:k1)(ef:EFct X)(j: X c_k1 mu2), - NAT j (m ef) mapmu2 -> F X c_k1 mu2. -Parameter In : InType. -Axiom mapmu2Red : forall (A:Set)(X:k1)(ef:EFct X)(j: X c_k1 mu2) - (n: NAT j (m ef) mapmu2)(t: F X A)(B:Set)(f:A->B), - mapmu2 f (In ef n t) = In ef n (m (FpEFct ef) f t). -Axiom MItRed : forall (G : k1) - (s : forall X : k1, X c_k1 G -> F X c_k1 G)(X : k1)(ef:EFct X)(j: X c_k1 mu2) - (n: NAT j (m ef) mapmu2)(A:Set)(t:F X A), - MIt s (In ef n t) = s X (fun A => (MIt s (A:=A)) o (j A)) A t. -Definition mu2IndType : Prop := - forall (P : (forall A : Set, mu2 A -> Prop)), - (forall (X : k1)(ef:EFct X)(j : X c_k1 mu2)(n: NAT j (m ef) mapmu2), - (forall (A : Set) (x : X A), P A (j A x)) -> - forall (A:Set)(t : F X A), P A (In ef n t)) -> - forall (A : Set) (r : mu2 A), P A r. -Axiom mu2Ind : mu2IndType. - -End LNMIt_Type. - -(** BushDepPredShort.v Version 0.2 July 2008 *) -(** does not need impredicative Set, produces stack overflow under V8.2, tested -with SVN 11296 *) - -(** Copyright Ralph Matthes, I.R.I.T., C.N.R.S. & University of Toulouse *) - -Set Implicit Arguments. - -Require Import List. - -Definition listk1 (A:Set) : Set := list A. -Open Scope type_scope. - -Definition BushF(X:k1)(A:Set) := unit + A * X (X A). - -Definition bushpEFct : pEFct BushF. -Proof. - unfold BushF. - apply sumpEFct. - apply constpEFct. - apply constEFct. - apply prodpEFct. - apply constpEFct. - apply idEFct. - apply comppEFct. - apply idpEFct. - apply idpEFct_eta. -Defined. - -Module Type BUSH := LNMIt_Type with Definition F:=BushF - with Definition FpEFct := -bushpEFct. - -Module Bush (BushBase:BUSH). - -Definition Bush : k1 := BushBase.mu2. - -Definition bush : mon Bush := BushBase.mapmu2. - -End Bush. - - -Definition Id : k1 := fun X => X. - -Fixpoint Pow (X:k1)(k:nat){struct k}:k1:= - match k with 0 => Id - | S k' => fun A => X (Pow X k' A) - end. - -Fixpoint POW (k:nat)(X:k1)(m:mon X){struct k} : mon (Pow X k) := - match k return mon (Pow X k) - with 0 => fun _ _ f => f - | S k' => fun _ _ f => m _ _ (POW k' m f) - end. - -Module Type BushkToList_Type. - -Declare Module Import BP: BUSH. -Definition F:=BushF. -Definition FpEFct:= bushpEFct. -Definition mu20 := mu20. -Definition mu2 := mu2. -Definition mapmu2 := mapmu2. -Definition MItType:= MItType. -Definition MIt0 := MIt0. -Definition MIt := MIt. -Definition InType := InType. -Definition In := In. -Definition mapmu2Red:=mapmu2Red. -Definition MItRed:=MItRed. -Definition mu2IndType:=mu2IndType. -Definition mu2Ind:=mu2Ind. - -Definition Bush:= mu2. -Module BushM := Bush BP. - -Parameter BushkToList: forall(k:nat)(A:k0)(t:Pow Bush k A), list A. -Axiom BushkToList0: forall(A:k0)(t:Pow Bush 0 A), BushkToList 0 A t = t::nil. - -End BushkToList_Type. - -Module BushDep (BushkToListM:BushkToList_Type). - -Module Bush := Bush BushkToListM. - -Import Bush. -Import BushkToListM. - - -Lemma BushkToList0NAT: NAT(Y:=listk1) (BushkToList 0) (POW 0 bush) map. -Proof. - red. - intros. - simpl. - rewrite BushkToList0. -(* stack overflow for coqc and coqtop *) - - -Abort. diff --git a/test-suite/bugs/closed/shouldsucceed/1925.v b/test-suite/bugs/closed/shouldsucceed/1925.v deleted file mode 100644 index 4caee1c3..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1925.v +++ /dev/null @@ -1,22 +0,0 @@ -(* Check that the analysis of projectable rel's in an evar instance is up to - aliases *) - -Require Import List. - -Definition compose (A B C : Type) (g : B -> C) (f : A -> B) : A -> C := - fun x : A => g(f x). - -Definition map_fuse' : - forall (A B C : Type) (g : B -> C) (f : A -> B) (xs : list A), - (map g (map f xs)) = map (compose _ _ _ g f) xs - := - fun A B C g f => - (fix loop (ys : list A) {struct ys} := - match ys as ys return (map g (map f ys)) = map (compose _ _ _ g f) ys - with - | nil => refl_equal nil - | x :: xs => - match loop xs in eq _ a return eq _ ((g (f x)) :: a) with - | refl_equal => refl_equal (map g (map f (x :: xs))) - end - end). diff --git a/test-suite/bugs/closed/shouldsucceed/1931.v b/test-suite/bugs/closed/shouldsucceed/1931.v deleted file mode 100644 index 930ace1d..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1931.v +++ /dev/null @@ -1,29 +0,0 @@ - - -Set Implicit Arguments. - -Inductive T (A:Set) : Set := - app : T A -> T A -> T A. - -Fixpoint map (A B:Set)(f:A->B)(t:T A) : T B := - match t with - app t1 t2 => app (map f t1)(map f t2) - end. - -Fixpoint subst (A B:Set)(f:A -> T B)(t:T A) :T B := - match t with - app t1 t2 => app (subst f t1)(subst f t2) - end. - -(* This is the culprit: *) -Definition k0:=Set. - -(** interaction of subst with map *) -Lemma substLaw1 (A:k0)(B C:Set)(f: A -> B)(g:B -> T C)(t: T A): - subst g (map f t) = subst (fun x => g (f x)) t. -Proof. - intros. - generalize B C f g; clear B C f g. - induction t; intros; simpl. - f_equal. -Admitted. diff --git a/test-suite/bugs/closed/shouldsucceed/1935.v b/test-suite/bugs/closed/shouldsucceed/1935.v deleted file mode 100644 index d5837619..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1935.v +++ /dev/null @@ -1,21 +0,0 @@ -Definition f (n:nat) := n = n. - -Lemma f_refl : forall n , f n. -intros. reflexivity. -Qed. - -Definition f' (x:nat) (n:nat) := n = n. - -Lemma f_refl' : forall n , f' n n. -Proof. - intros. reflexivity. -Qed. - -Require Import ZArith. - -Definition f'' (a:bool) := if a then eq (A:= Z) else Z.lt. - -Lemma f_refl'' : forall n , f'' true n n. -Proof. - intro. reflexivity. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1939.v b/test-suite/bugs/closed/shouldsucceed/1939.v deleted file mode 100644 index 5e61529b..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1939.v +++ /dev/null @@ -1,19 +0,0 @@ -Require Import Setoid Program.Basics. - - Parameter P : nat -> Prop. - Parameter R : nat -> nat -> Prop. - - Add Parametric Morphism : P - with signature R ++> impl as PM1. - Admitted. - - Add Parametric Morphism : P - with signature R --> impl as PM2. - Admitted. - - Goal forall x y, R x y -> P y -> P x. - Proof. - intros x y H1 H2. - rewrite H1. - auto. - Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1944.v b/test-suite/bugs/closed/shouldsucceed/1944.v deleted file mode 100644 index ee2918c6..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1944.v +++ /dev/null @@ -1,9 +0,0 @@ -(* Test some uses of ? in introduction patterns *) - -Inductive J : nat -> Prop := - | K : forall p, J p -> (True /\ True) -> J (S p). - -Lemma bug : forall n, J n -> J (S n). -Proof. - intros ? H. - induction H as [? ? [? ?]]. diff --git a/test-suite/bugs/closed/shouldsucceed/1951.v b/test-suite/bugs/closed/shouldsucceed/1951.v deleted file mode 100644 index 12c0ef9b..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1951.v +++ /dev/null @@ -1,63 +0,0 @@ - -(* First a simplification of the bug *) - -Set Printing Universes. - -Inductive enc (A:Type (*1*)) (* : Type.1 *) := C : A -> enc A. - -Definition id (X:Type(*5*)) (x:X) := x. - -Lemma test : let S := Type(*6 : 7*) in enc S -> S. -simpl; intros. -apply enc. -apply id. -apply Prop. -Defined. - -(* Then the original bug *) - -Require Import List. - -Inductive a : Set := (* some dummy inductive *) -b : (list a) -> a. (* i don't know if this *) - (* happens for smaller *) - (* ones *) - -Inductive sg : Type := Sg. (* single *) - -Definition ipl2 (P : a -> Type) := (* in Prop, that means P is true forall *) -fold_right (fun x => prod (P x)) sg. (* the elements of a given list *) - -Definition ind - : forall S : a -> Type, - (forall ls : list a, ipl2 S ls -> S (b ls)) -> forall s : a, S s := -fun (S : a -> Type) - (X : forall ls : list a, ipl2 S ls -> S (b ls)) => -fix ind2 (s : a) := -match s as a return (S a) with -| b l => - X l - (list_rect (fun l0 : list a => ipl2 S l0) Sg - (fun (a0 : a) (l0 : list a) (IHl : ipl2 S l0) => - pair (ind2 a0) IHl) l) -end. (* some induction principle *) - -Implicit Arguments ind [S]. - -Lemma k : a -> Type. (* some ininteresting lemma *) -intro;pattern H;apply ind;intros. - assert (K : Type). - induction ls. - exact sg. - exact sg. - exact (prod K sg). -Defined. - -Lemma k' : a -> Type. (* same lemma but with our bug *) -intro;pattern H;apply ind;intros. - apply prod. - induction ls. - exact sg. - exact sg. - exact sg. (* Proof complete *) -Defined. (* bug *) diff --git a/test-suite/bugs/closed/shouldsucceed/1962.v b/test-suite/bugs/closed/shouldsucceed/1962.v deleted file mode 100644 index a6b0fee5..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1962.v +++ /dev/null @@ -1,55 +0,0 @@ -(* Bug 1962.v - -Bonjour, - -J'ai un exemple de lemme que j'arrivais à prouver avec fsetdec avec la 8.2beta3 -avec la beta4 et la version svn 11447 branche 8.2 çà diverge. - -Voici l'exemple en question, l'exmple test2 marche bien dans les deux version, -test en revanche pose probleme: - -*) - -Require Export FSets. - -(** This module takes a decidable type and -build finite sets of this type, tactics and defs *) - -Module BuildFSets (DecPoints: UsualDecidableType). - -Module Export FiniteSetsOfPoints := FSetWeakList.Make DecPoints. -Module Export FiniteSetsOfPointsProperties := - WProperties FiniteSetsOfPoints. -Module Export Dec := WDecide FiniteSetsOfPoints. -Module Export FM := Dec.F. - -Definition set_of_points := t. -Definition Point := DecPoints.t. - -Definition couple(x y :Point) : set_of_points := -add x (add y empty). - -Definition triple(x y t :Point): set_of_points := -add x (add y (add t empty)). - -Lemma test : forall P A B C A' B' C', -Equal -(union (singleton P) (union (triple A B C) (triple A' B' C'))) -(union (triple P B B') (union (couple P A) (triple C A' C'))). -Proof. -intros. -unfold triple, couple. -Time fsetdec. (* works in 8.2 beta 3, not in beta 4 and final 8.2 *) - (* appears to works again in 8.3 and trunk, take 4-6 seconds *) -Qed. - -Lemma test2 : forall A B C, -Equal - (union (singleton C) (couple A B)) (triple A B C). -Proof. -intros. -unfold triple, couple. -Time fsetdec. -Qed. - -End BuildFSets. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1963.v b/test-suite/bugs/closed/shouldsucceed/1963.v deleted file mode 100644 index 11e2ee44..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1963.v +++ /dev/null @@ -1,19 +0,0 @@ -(* Check that "dependent inversion" behaves correctly w.r.t to universes *) - -Require Import Eqdep. - -Set Implicit Arguments. - -Inductive illist(A:Type) : nat -> Type := - illistn : illist A 0 -| illistc : forall n:nat, A -> illist A n -> illist A (S n). - -Inductive isig (A:Type)(P:A -> Type) : Type := - iexists : forall x : A, P x -> isig P. - -Lemma inv : forall (A:Type)(n n':nat)(ts':illist A n'), n' = S n -> - isig (fun t => isig (fun ts => - eq_dep nat (fun n => illist A n) n' ts' (S n) (illistc t ts))). -Proof. -intros. -dependent inversion ts'. diff --git a/test-suite/bugs/closed/shouldsucceed/1977.v b/test-suite/bugs/closed/shouldsucceed/1977.v deleted file mode 100644 index 28715040..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1977.v +++ /dev/null @@ -1,4 +0,0 @@ -Inductive T {A} : Prop := c : A -> T. -Goal (@T nat). -apply c. exact 0. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1981.v b/test-suite/bugs/closed/shouldsucceed/1981.v deleted file mode 100644 index 99952682..00000000 --- a/test-suite/bugs/closed/shouldsucceed/1981.v +++ /dev/null @@ -1,5 +0,0 @@ -Implicit Arguments ex_intro [A]. - -Goal exists n : nat, True. - eapply ex_intro. exact 0. exact I. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2001.v b/test-suite/bugs/closed/shouldsucceed/2001.v deleted file mode 100644 index d0b3bf17..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2001.v +++ /dev/null @@ -1,22 +0,0 @@ -(* Automatic computing of guard in "Theorem with"; check that guard is not - computed when the user explicitly indicated it *) - -Unset Automatic Introduction. - -Inductive T : Set := -| v : T. - -Definition f (s:nat) (t:T) : nat. -fix 2. -intros s t. -refine - match t with - | v => s - end. -Defined. - -Lemma test : - forall s, f s v = s. -Proof. -reflexivity. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2017.v b/test-suite/bugs/closed/shouldsucceed/2017.v deleted file mode 100644 index df666148..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2017.v +++ /dev/null @@ -1,15 +0,0 @@ -(* Some check of Miller's pattern inference - used to fail in 8.2 due - first to the presence of aliases, secondly due to the absence of - restriction of the potential interesting variables to the subset of - variables effectively occurring in the term to instantiate *) - -Set Implicit Arguments. - -Variable choose : forall(P : bool -> Prop)(H : exists x, P x), bool. - -Variable H : exists x : bool, True. - -Definition coef := -match Some true with - Some _ => @choose _ H |_ => true -end . diff --git a/test-suite/bugs/closed/shouldsucceed/2021.v b/test-suite/bugs/closed/shouldsucceed/2021.v deleted file mode 100644 index e598e5ae..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2021.v +++ /dev/null @@ -1,23 +0,0 @@ -(* correct failure of injection/discriminate on types whose inductive - status derives from the substitution of an argument *) - -Inductive t : nat -> Type := -| M : forall n: nat, nat -> t n. - -Lemma eq_t : forall n n' m m', - existT (fun B : Type => B) (t n) (M n m) = - existT (fun B : Type => B) (t n') (M n' m') -> True. -Proof. - intros. - injection H. - intro Ht. - exact I. -Qed. - -Lemma eq_t' : forall n n' : nat, - existT (fun B : Type => B) (t n) (M n 0) = - existT (fun B : Type => B) (t n') (M n' 1) -> True. -Proof. - intros. - discriminate H || exact I. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2027.v b/test-suite/bugs/closed/shouldsucceed/2027.v deleted file mode 100644 index fb53c6ef..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2027.v +++ /dev/null @@ -1,11 +0,0 @@ - -Parameter T : Type -> Type. -Parameter f : forall {A}, T A -> T A. -Parameter P : forall {A}, T A -> Prop. -Axiom f_id : forall {A} (l : T A), f l = l. - -Goal forall A (p : T A), P p. -Proof. - intros. - rewrite <- f_id. -Admitted. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2083.v b/test-suite/bugs/closed/shouldsucceed/2083.v deleted file mode 100644 index a6ce4de0..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2083.v +++ /dev/null @@ -1,27 +0,0 @@ -Require Import Program Arith. - -Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) - (H : forall (i : { i | i < n }), i < p -> P i = true) - {measure (n - p)} : - Exc (forall (p : { i | i < n}), P p = true) := - match le_lt_dec n p with - | left _ => value _ - | right cmp => - if dec (P p) then - check_n n P (S p) _ - else - error - end. - -Require Import Omega. - -Solve Obligations using program_simpl ; auto with *; try omega. - -Next Obligation. - apply H. simpl. omega. -Defined. - -Next Obligation. - case (le_lt_dec p i) ; intros. assert(i = p) by omega. subst. - revert H0. clear_subset_proofs. auto. - apply H. simpl. assumption. Defined. diff --git a/test-suite/bugs/closed/shouldsucceed/2089.v b/test-suite/bugs/closed/shouldsucceed/2089.v deleted file mode 100644 index aebccc94..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2089.v +++ /dev/null @@ -1,17 +0,0 @@ -Inductive even (x: nat): nat -> Prop := - | even_base: even x O - | even_succ: forall n, odd x n -> even x (S n) - -with odd (x: nat): nat -> Prop := - | odd_succ: forall n, even x n -> odd x (S n). - -Scheme even_ind2 := Minimality for even Sort Prop - with odd_ind2 := Minimality for odd Sort Prop. - -Combined Scheme even_odd_ind from even_ind2, odd_ind2. - -Check (even_odd_ind :forall (x : nat) (P P0 : nat -> Prop), - P 0 -> - (forall n : nat, odd x n -> P0 n -> P (S n)) -> - (forall n : nat, even x n -> P n -> P0 (S n)) -> - (forall n : nat, even x n -> P n) /\ (forall n : nat, odd x n -> P0 n)). diff --git a/test-suite/bugs/closed/shouldsucceed/2095.v b/test-suite/bugs/closed/shouldsucceed/2095.v deleted file mode 100644 index 28ea99df..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2095.v +++ /dev/null @@ -1,19 +0,0 @@ -(* Classes and sections *) - -Section OPT. - Variable A: Type. - - Inductive MyOption: Type := - | MyNone: MyOption - | MySome: A -> MyOption. - - Class Opt: Type := { - f_opt: A -> MyOption - }. -End OPT. - -Definition f_nat (n: nat): MyOption nat := MySome _ n. - -Instance Nat_Opt: Opt nat := { - f_opt := f_nat -}. diff --git a/test-suite/bugs/closed/shouldsucceed/2108.v b/test-suite/bugs/closed/shouldsucceed/2108.v deleted file mode 100644 index cad8baa9..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2108.v +++ /dev/null @@ -1,22 +0,0 @@ -(* Declare Module in Module Type *) -Module Type A. -Record t : Set := { something : unit }. -End A. - - -Module Type B. -Declare Module BA : A. -End B. - - -Module Type C. -Declare Module CA : A. -Declare Module CB : B with Module BA := CA. -End C. - - -Module Type D. -Declare Module DA : A. -(* Next line gives: "Anomaly: uncaught exception Not_found. Please report." *) -Declare Module DC : C with Module CA := DA. -End D. diff --git a/test-suite/bugs/closed/shouldsucceed/2117.v b/test-suite/bugs/closed/shouldsucceed/2117.v deleted file mode 100644 index 6377a8b7..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2117.v +++ /dev/null @@ -1,56 +0,0 @@ -(* Check pattern-unification on evars in apply unification *) - -Axiom app : forall tau tau':Type, (tau -> tau') -> tau -> tau'. - -Axiom copy : forall tau:Type, tau -> tau -> Prop. -Axiom copyr : forall tau:Type, tau -> tau -> Prop. -Axiom copyf : forall tau:Type, tau -> tau -> Prop. -Axiom eq : forall tau:Type, tau -> tau -> Prop. -Axiom subst : forall tau tau':Type, (tau -> tau') -> tau -> tau' -> Prop. - -Axiom copy_atom : forall tau:Type, forall t t':tau, eq tau t t' -> copy tau t t'. -Axiom copy_fun: forall tau tau':Type, forall t t':(tau->tau'), -(forall x:tau, copyr tau x x->copy tau' (t x) (t' x)) -->copy (tau->tau') t t'. - -Axiom copyr_atom : forall tau:Type, forall t t':tau, copyr tau t t' -> eq tau t t'. -Axiom copyr_fun: forall tau tau':Type, forall t t':(tau->tau'), -copyr (tau->tau') t t' -->(forall x y:tau, copy tau x y->copyr tau' (t x) (t' y)). - -Axiom copyf_atom : forall tau:Type, forall t t':tau, copyf tau t t' -> eq tau t t'. -Axiom copyf_fun: forall tau tau':Type, forall t t':(tau->tau'), -copyr (tau->tau') t t' -->(forall x y:tau, forall z1 z2:tau', -(copy tau x y)-> -(subst tau tau' t x z1)-> -(subst tau tau' t' y z2)-> -copyf tau' z1 z2). - -Axiom eqappg: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau',forall t':tau', -( ((subst tau tau' t q t') /\ (eq tau' t' r)) -->eq tau' (app tau tau' t q) r). - -Axiom eqappd: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau', -forall t':tau', ((subst tau tau' t q t') /\ (eq tau' r t')) -->eq tau' r (app tau tau' t q). - -Axiom substcopy: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau', -(forall x:tau, (copyf tau x q) -> (copy tau' (t x) r)) -->subst tau tau' t q r. - -Ltac EtaLong := (apply copy_fun;intros;EtaLong)|| apply copy_atom. -Ltac Subst := apply substcopy;intros;EtaLong. -Ltac Rigid_aux := fun A => apply A|| Rigid_aux (copyr_fun _ _ _ _ A). -Ltac Rigid := fun A => apply copyr_atom; Rigid_aux A. - -Theorem church0: forall i:Type, exists X:(i->i)->i->i, -copy ((i->i)->i->i) (fun f:i->i => fun x:i=>f (X f x)) (fun f:i->i=>fun x:i=>app i i (X f) (f x)). -intros. -esplit. -EtaLong. -eapply eqappd;split. -Subst. -apply copyf_atom. -Show Existentials. -apply H1. diff --git a/test-suite/bugs/closed/shouldsucceed/2123.v b/test-suite/bugs/closed/shouldsucceed/2123.v deleted file mode 100644 index 422a2c12..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2123.v +++ /dev/null @@ -1,11 +0,0 @@ -(* About the detection of non-dependent metas by the refine tactic *) - -(* The following is a simplification of bug #2123 *) - -Parameter fset : nat -> Set. -Parameter widen : forall (n : nat) (s : fset n), { x : fset (S n) | s=s }. -Goal forall i, fset (S i). -intro. -refine (proj1_sig (widen i _)). - - diff --git a/test-suite/bugs/closed/shouldsucceed/2127.v b/test-suite/bugs/closed/shouldsucceed/2127.v deleted file mode 100644 index 142ada26..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2127.v +++ /dev/null @@ -1,8 +0,0 @@ -(* Check that "apply eq_refl" is not exported as an interactive - tactic but as a statically globalized one *) - -(* (this is a simplification of the original bug report) *) - -Module A. -Hint Rewrite eq_sym using apply eq_refl : foo. -End A. diff --git a/test-suite/bugs/closed/shouldsucceed/2135.v b/test-suite/bugs/closed/shouldsucceed/2135.v deleted file mode 100644 index 61882176..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2135.v +++ /dev/null @@ -1,9 +0,0 @@ -(* Check that metas are whd-normalized before trying 2nd-order unification *) -Lemma test : - forall (D:Type) (T : forall C, option C) (Q:forall D, option D -> Prop), - (forall (A : Type) (P : forall B:Type, option B -> Prop), P A (T A)) - -> Q D (T D). -Proof. - intros D T Q H. - pattern (T D). apply H. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2136.v b/test-suite/bugs/closed/shouldsucceed/2136.v deleted file mode 100644 index d2b926f3..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2136.v +++ /dev/null @@ -1,61 +0,0 @@ -(* Bug #2136 - -The fsetdec tactic seems to get confused by hypotheses like - HeqH1 : H1 = MkEquality s0 s1 b -If I clear them then it is able to solve my goal; otherwise it is not. -I would expect it to be able to solve the goal even without this hypothesis -being cleared. A small, self-contained example is below. - -I have coq r12238. - - -Thanks -Ian -*) - - -Require Import FSets. -Require Import Arith. -Require Import FSetWeakList. - -Module DecidableNat. -Definition t := nat. -Definition eq := @eq nat. -Definition eq_refl := @refl_equal nat. -Definition eq_sym := @sym_eq nat. -Definition eq_trans := @trans_eq nat. -Definition eq_dec := eq_nat_dec. -End DecidableNat. - -Module NatSet := Make(DecidableNat). - -Module Export Dec := WDecide (NatSet). -Import FSetDecideAuxiliary. - -Parameter MkEquality : forall ( s0 s1 : NatSet.t ) - ( x : nat ), - NatSet.Equal s1 (NatSet.add x s0). - -Lemma ThisLemmaWorks : forall ( s0 s1 : NatSet.t ) - ( a b : nat ), - NatSet.In a s0 - -> NatSet.In a s1. -Proof. -intros. -remember (MkEquality s0 s1 b) as H1. -clear HeqH1. -fsetdec. -Qed. - -Lemma ThisLemmaWasFailing : forall ( s0 s1 : NatSet.t ) - ( a b : nat ), - NatSet.In a s0 - -> NatSet.In a s1. -Proof. -intros. -remember (MkEquality s0 s1 b) as H1. -fsetdec. -(* -Error: Tactic failure: because the goal is beyond the scope of this tactic. -*) -Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2137.v b/test-suite/bugs/closed/shouldsucceed/2137.v deleted file mode 100644 index 6c2023ab..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2137.v +++ /dev/null @@ -1,52 +0,0 @@ -(* Bug #2137 - -The fsetdec tactic is sensitive to which way round the arguments to <> are. -In the small, self-contained example below, it is able to solve the goal -if it knows that "b <> a", but not if it knows that "a <> b". I would expect -it to be able to solve hte goal in either case. - -I have coq r12238. - - -Thanks -Ian - -*) - -Require Import Arith FSets FSetWeakList. - -Module DecidableNat. -Definition t := nat. -Definition eq := @eq nat. -Definition eq_refl := @refl_equal nat. -Definition eq_sym := @sym_eq nat. -Definition eq_trans := @trans_eq nat. -Definition eq_dec := eq_nat_dec. -End DecidableNat. - -Module NatSet := Make(DecidableNat). - -Module Export NameSetDec := WDecide (NatSet). - -Lemma ThisLemmaWorks : forall ( s0 : NatSet.t ) - ( a b : nat ), - b <> a - -> ~(NatSet.In a s0) - -> ~(NatSet.In a (NatSet.add b s0)). -Proof. -intros. -fsetdec. -Qed. - -Lemma ThisLemmaWasFailing : forall ( s0 : NatSet.t ) - ( a b : nat ), - a <> b - -> ~(NatSet.In a s0) - -> ~(NatSet.In a (NatSet.add b s0)). -Proof. -intros. -fsetdec. -(* -Error: Tactic failure: because the goal is beyond the scope of this tactic. -*) -Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2139.v b/test-suite/bugs/closed/shouldsucceed/2139.v deleted file mode 100644 index a7f35508..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2139.v +++ /dev/null @@ -1,24 +0,0 @@ -(* Call of apply on <-> failed because of evars in elimination predicate *) -Generalizable Variables patch. - -Class Patch (patch : Type) := { - commute : patch -> patch -> Prop -}. - -Parameter flip : forall `{patchInstance : Patch patch} - {a b : patch}, - commute a b <-> commute b a. - -Lemma Foo : forall `{patchInstance : Patch patch} - {a b : patch}, - (commute a b) - -> True. -Proof. -intros. -apply flip in H. - -(* failed in well-formed arity check because elimination predicate of - iff in (@flip _ _ _ _) had normalized evars while the ones in the - type of (@flip _ _ _ _) itself had non-normalized evars *) - -(* By the way, is the check necessary ? *) diff --git a/test-suite/bugs/closed/shouldsucceed/2141.v b/test-suite/bugs/closed/shouldsucceed/2141.v deleted file mode 100644 index 941ae530..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2141.v +++ /dev/null @@ -1,14 +0,0 @@ -Require Import FSetList. -Require Import OrderedTypeEx. - -Module NatSet := FSetList.Make (Nat_as_OT). -Recursive Extraction NatSet.fold. - -Module FSetHide (X : FSetInterface.S). - Include X. -End FSetHide. - -Module NatSet' := FSetHide NatSet. -Recursive Extraction NatSet'.fold. - -(* Extraction "test2141.ml" NatSet'.fold. *) \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2145.v b/test-suite/bugs/closed/shouldsucceed/2145.v deleted file mode 100644 index 4dc0de74..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2145.v +++ /dev/null @@ -1,20 +0,0 @@ -(* Test robustness of Groebner tactic in presence of disequalities *) - -Require Export Reals. -Require Export Nsatz. - -Open Scope R_scope. - -Lemma essai : - forall yb xb m1 m2 xa ya, - xa <> xb -> - yb - 2 * m2 * xb = ya - m2 * xa -> - yb - m1 * xb = ya - m1 * xa -> - yb - ya = (2 * xb - xa) * m2 -> - yb - ya = (xb - xa) * m1. -Proof. -intros. -(* clear H. groebner used not to work when H was not cleared *) -nsatz. -Qed. - diff --git a/test-suite/bugs/closed/shouldsucceed/2181.v b/test-suite/bugs/closed/shouldsucceed/2181.v deleted file mode 100644 index 62820d86..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2181.v +++ /dev/null @@ -1,3 +0,0 @@ -Class C. -Parameter P: C -> Prop. -Fail Record R: Type := { _: C; u: P _ }. diff --git a/test-suite/bugs/closed/shouldsucceed/2193.v b/test-suite/bugs/closed/shouldsucceed/2193.v deleted file mode 100644 index fe258867..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2193.v +++ /dev/null @@ -1,31 +0,0 @@ -(* Computation of dependencies in the "match" return predicate was incomplete *) -(* Submitted by R. O'Connor, Nov 2009 *) - -Inductive Symbol : Set := - | VAR : Symbol. - -Inductive SExpression := - | atomic : Symbol -> SExpression. - -Inductive ProperExpr : SExpression -> SExpression -> Type := - | pe_3 : forall (x : Symbol) (alpha : SExpression), - ProperExpr alpha (atomic VAR) -> - ProperExpr (atomic x) alpha. - -Definition A (P : forall s : SExpression, Type) - (x alpha alpha1 : SExpression) - (t : ProperExpr (x) alpha1) : option (x = atomic VAR) := - match t as pe in ProperExpr a b return option (a = atomic VAR) with - | pe_3 x0 alpha3 tye' => - (fun (x:Symbol) (alpha : SExpression) => @None (atomic x = atomic VAR)) - x0 alpha3 - end. - -Definition B (P : forall s : SExpression, Type) - (x alpha alpha1 : SExpression) - (t : ProperExpr (x) alpha1) : option (x = atomic VAR) := - match t as pe in ProperExpr a b return option (a = atomic VAR) with - | pe_3 x0 alpha3 tye' => - (fun (x:Symbol) (alpha : SExpression) (t:ProperExpr alpha (atomic VAR)) => @None (atomic x = atomic VAR)) - x0 alpha3 tye' - end. diff --git a/test-suite/bugs/closed/shouldsucceed/2230.v b/test-suite/bugs/closed/shouldsucceed/2230.v deleted file mode 100644 index 5076fb2b..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2230.v +++ /dev/null @@ -1,6 +0,0 @@ -Goal forall f, f 1 1 -> True. -intros. -match goal with - | [ H : _ ?a |- _ ] => idtac -end. -Abort. diff --git a/test-suite/bugs/closed/shouldsucceed/2231.v b/test-suite/bugs/closed/shouldsucceed/2231.v deleted file mode 100644 index 03e2c9bb..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2231.v +++ /dev/null @@ -1,3 +0,0 @@ -Inductive unit2 : Type := U : unit -> unit2. -Inductive dummy (u: unit2) : unit -> Type := - V: dummy u (let (tt) := u in tt). diff --git a/test-suite/bugs/closed/shouldsucceed/2244.v b/test-suite/bugs/closed/shouldsucceed/2244.v deleted file mode 100644 index d499e515..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2244.v +++ /dev/null @@ -1,19 +0,0 @@ -(* 1st-order unification did not work when in competition with pattern unif. *) - -Set Implicit Arguments. -Lemma test : forall - (A : Type) - (B : Type) - (f : A -> B) - (S : B -> Prop) - (EV : forall y (f':A->B), (forall x', S (f' x')) -> S (f y)) - (HS : forall x', S (f x')) - (x : A), - S (f x). -Proof. - intros. eapply EV. intros. - (* worked in v8.2 but not in v8.3beta, fixed in r12898 *) - apply HS. - - (* still not compatible with 8.2 because an evar can be solved in - two different ways and is left open *) diff --git a/test-suite/bugs/closed/shouldsucceed/2255.v b/test-suite/bugs/closed/shouldsucceed/2255.v deleted file mode 100644 index bf80ff66..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2255.v +++ /dev/null @@ -1,21 +0,0 @@ -(* Check injection in presence of dependencies hidden in applicative terms *) - -Inductive TupleT : nat -> Type := - nilT : TupleT 0 -| consT {n} A : (A -> TupleT n) -> TupleT (S n). - -Inductive Tuple : forall n, TupleT n -> Type := - nil : Tuple _ nilT -| cons {n} A (x : A) (F : A -> TupleT n) : Tuple _ (F x) -> Tuple _ (consT A F). - -Goal forall n A F x X n0 A0 x0 F0 H0 (H : existT (fun n0 : nat => {H0 : TupleT -n0 & Tuple n0 H0}) - (S n0) - (existT (fun H0 : TupleT (S n0) => Tuple (S n0) H0) - (consT A0 F0) (cons A0 x0 F0 H0)) = - existT (fun n0 : nat => {H0 : TupleT n0 & Tuple n0 H0}) - (S n) - (existT (fun H0 : TupleT (S n) => Tuple (S n) H0) - (consT A F) (cons A x F X))), False. -intros. -injection H. diff --git a/test-suite/bugs/closed/shouldsucceed/2262.v b/test-suite/bugs/closed/shouldsucceed/2262.v deleted file mode 100644 index b61f18b8..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2262.v +++ /dev/null @@ -1,11 +0,0 @@ - - -Generalizable Variables A. -Class Test A := { test : A }. - -Lemma mylemma : forall `{Test A}, test = test. -Admitted. (* works fine *) - -Definition mylemma' := forall `{Test A}, test = test. -About mylemma'. - diff --git a/test-suite/bugs/closed/shouldsucceed/2281.v b/test-suite/bugs/closed/shouldsucceed/2281.v deleted file mode 100644 index 40948d90..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2281.v +++ /dev/null @@ -1,50 +0,0 @@ -(** Bug #2281 - -In the code below, coq is confused by an equality unless it is first 'subst'ed -away, yet http://coq.inria.fr/stdlib/Coq.FSets.FSetDecide.html says - - fsetdec will first perform any necessary zeta and beta reductions and will -invoke subst to eliminate any Coq equalities between finite sets or their -elements. - -I have coq r12851. - -*) - -Require Import Arith. -Require Import FSets. -Require Import FSetWeakList. - -Module DecidableNat. -Definition t := nat. -Definition eq := @eq nat. -Definition eq_refl := @refl_equal nat. -Definition eq_sym := @sym_eq nat. -Definition eq_trans := @trans_eq nat. -Definition eq_dec := eq_nat_dec. -End DecidableNat. - -Module NatSet := Make(DecidableNat). - -Module Export NameSetDec := WDecide (NatSet). - -Lemma ThisLemmaWorks : forall ( s1 s2 : NatSet.t ) - ( H : s1 = s2 ), - NatSet.Equal s1 s2. -Proof. -intros. -subst. -fsetdec. -Qed. - -Import FSetDecideAuxiliary. - -Lemma ThisLemmaWasFailing : forall ( s1 s2 : NatSet.t ) - ( H : s1 = s2 ), - NatSet.Equal s1 s2. -Proof. -intros. -fsetdec. -(* Error: Tactic failure: because the goal is beyond the scope of this tactic. -*) -Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2295.v b/test-suite/bugs/closed/shouldsucceed/2295.v deleted file mode 100644 index f5ca28dc..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2295.v +++ /dev/null @@ -1,11 +0,0 @@ -(* Check if omission of "as" in return clause works w/ section variables too *) - -Section sec. - -Variable b: bool. - -Definition d' := - (match b return b = true \/ b = false with - | true => or_introl _ (refl_equal true) - | false => or_intror _ (refl_equal false) - end). diff --git a/test-suite/bugs/closed/shouldsucceed/2299.v b/test-suite/bugs/closed/shouldsucceed/2299.v deleted file mode 100644 index c0552ca7..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2299.v +++ /dev/null @@ -1,13 +0,0 @@ -(* Check that destruct refreshes universes in what it generalizes *) - -Section test. - -Variable A: Type. - -Inductive T: unit -> Type := C: A -> unit -> T tt. - -Let unused := T tt. - -Goal T tt -> False. - intro X. - destruct X. diff --git a/test-suite/bugs/closed/shouldsucceed/2300.v b/test-suite/bugs/closed/shouldsucceed/2300.v deleted file mode 100644 index 4e587cbb..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2300.v +++ /dev/null @@ -1,15 +0,0 @@ -(* Check some behavior of Ltac pattern-matching wrt universe levels *) - -Section contents. - -Variables (A: Type) (B: (unit -> Type) -> Type). - -Inductive C := c: A -> unit -> C. - -Let unused2 (x: unit) := C. - -Goal True. -intuition. -Qed. - -End contents. diff --git a/test-suite/bugs/closed/shouldsucceed/2303.v b/test-suite/bugs/closed/shouldsucceed/2303.v deleted file mode 100644 index e614b9b5..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2303.v +++ /dev/null @@ -1,4 +0,0 @@ -Class A := a: unit. -Class B (x: unit). -Axiom H: forall x: A, @B x -> x = x -> unit. -Definition Field (z: A) (m: @B z) x := (@H _ _ x) = z. diff --git a/test-suite/bugs/closed/shouldsucceed/2304.v b/test-suite/bugs/closed/shouldsucceed/2304.v deleted file mode 100644 index 1ac2702b..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2304.v +++ /dev/null @@ -1,4 +0,0 @@ -(* This used to fail with an anomaly NotASort at some time *) -Class A (O: Type): Type := a: O -> Type. -Fail Goal forall (x: a tt), @a x = @a x. - diff --git a/test-suite/bugs/closed/shouldsucceed/2307.v b/test-suite/bugs/closed/shouldsucceed/2307.v deleted file mode 100644 index 7c049495..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2307.v +++ /dev/null @@ -1,3 +0,0 @@ -Inductive V: nat -> Type := VS n: V (S n). -Definition f (e: V 1): nat := match e with VS 0 => 3 end. - diff --git a/test-suite/bugs/closed/shouldsucceed/2320.v b/test-suite/bugs/closed/shouldsucceed/2320.v deleted file mode 100644 index facb9ecf..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2320.v +++ /dev/null @@ -1,14 +0,0 @@ -(* Managing metavariables in the return clause of a match *) - -(* This was working in 8.1 but is failing in 8.2 and 8.3. It works in - trunk thanks to the new proof engine. It could probably made to work in - 8.2 and 8.3 if a return predicate of the form "dummy 0" instead of - (or in addition to) a sophisticated predicate of the form - "as x in dummy y return match y with 0 => ?P | _ => ID end" *) - -Inductive dummy : nat -> Prop := constr : dummy 0. - -Lemma failure : forall (x : dummy 0), x = constr. -Proof. -intros x. -refine (match x with constr => _ end). diff --git a/test-suite/bugs/closed/shouldsucceed/2342.v b/test-suite/bugs/closed/shouldsucceed/2342.v deleted file mode 100644 index 094e5466..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2342.v +++ /dev/null @@ -1,8 +0,0 @@ -(* Checking that the type inference algoithme does not commit to an - equality over sorts when only a subtyping constraint is around *) - -Parameter A : Set. -Parameter B : A -> Set. -Parameter F : Set -> Prop. -Check (F (forall x, B x)). - diff --git a/test-suite/bugs/closed/shouldsucceed/2347.v b/test-suite/bugs/closed/shouldsucceed/2347.v deleted file mode 100644 index e433f158..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2347.v +++ /dev/null @@ -1,10 +0,0 @@ -Require Import EquivDec List. -Generalizable All Variables. - -Program Definition list_eqdec `(eqa : EqDec A eq) : EqDec (list A) eq := - (fun (x y : list A) => _). -Admit Obligations of list_eqdec. - -Program Definition list_eqdec' `(eqa : EqDec A eq) : EqDec (list A) eq := - (fun _ : nat => (fun (x y : list A) => _)) 0. -Admit Obligations of list_eqdec'. diff --git a/test-suite/bugs/closed/shouldsucceed/2350.v b/test-suite/bugs/closed/shouldsucceed/2350.v deleted file mode 100644 index e91f22e2..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2350.v +++ /dev/null @@ -1,6 +0,0 @@ -(* Check that the fix tactic, when called from refine, reduces enough - to see the products *) - -Definition foo := forall n:nat, n=n. -Definition bar : foo. -refine (fix aux (n:nat) := _). diff --git a/test-suite/bugs/closed/shouldsucceed/2353.v b/test-suite/bugs/closed/shouldsucceed/2353.v deleted file mode 100644 index b5c45c28..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2353.v +++ /dev/null @@ -1,12 +0,0 @@ -(* Are recursively non-uniform params correctly treated? *) -Inductive list (A:nat -> Type) n := cons : A n -> list A (S n) -> list A n. -Inductive term n := app (l : list term n). -Definition term_list := - fix term_size n (t : term n) (acc : nat) {struct t} : nat := - match t with - | app l => - (fix term_list_size n (l : list term n) (acc : nat) {struct l} : nat := - match l with - | cons t q => term_list_size (S n) q (term_size n t acc) - end) n l (S acc) - end. diff --git a/test-suite/bugs/closed/shouldsucceed/2360.v b/test-suite/bugs/closed/shouldsucceed/2360.v deleted file mode 100644 index 4ae97c97..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2360.v +++ /dev/null @@ -1,13 +0,0 @@ -(* This failed in V8.3 because descend_in_conjunctions built ill-typed terms *) -Definition interp (etyp : nat -> Type) (p: nat) := etyp p. - -Record Value (etyp : nat -> Type) := Mk { - typ : nat; - value : interp etyp typ -}. - -Definition some_value (etyp : nat -> Type) : (Value etyp). -Proof. - intros. - Fail apply Mk. (* Check that it does not raise an anomaly *) - diff --git a/test-suite/bugs/closed/shouldsucceed/2362.v b/test-suite/bugs/closed/shouldsucceed/2362.v deleted file mode 100644 index febb9c7b..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2362.v +++ /dev/null @@ -1,38 +0,0 @@ -Set Implicit Arguments. - -Class Pointed (M:Type -> Type) := -{ - creturn: forall {A: Type}, A -> M A -}. - -Unset Implicit Arguments. -Inductive FPair (A B:Type) (neutral: B) : Type:= - fpair : forall (a:A) (b:B), FPair A B neutral. -Implicit Arguments fpair [[A] [B] [neutral]]. - -Set Implicit Arguments. - -Notation "( x ,> y )" := (fpair x y) (at level 0). - -Instance Pointed_FPair B neutral: - Pointed (fun A => FPair A B neutral) := - { creturn := fun A (a:A) => (a,> neutral) }. -Definition blah_fail (x:bool) : FPair bool nat O := - creturn x. -Set Printing All. Print blah_fail. - -Definition blah_explicit (x:bool) : FPair bool nat O := - @creturn _ (Pointed_FPair _ ) _ x. - -Print blah_explicit. - - -Instance Pointed_FPair_mono: - Pointed (fun A => FPair A nat 0) := - { creturn := fun A (a:A) => (a,> 0) }. - - -Definition blah (x:bool) : FPair bool nat O := - creturn x. - - diff --git a/test-suite/bugs/closed/shouldsucceed/2375.v b/test-suite/bugs/closed/shouldsucceed/2375.v deleted file mode 100644 index c17c426c..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2375.v +++ /dev/null @@ -1,18 +0,0 @@ -(* In the following code, the (superfluous) lemma [lem] is responsible -for the failure of congruence. *) - -Definition f : nat -> Prop := fun x => True. - -Lemma lem : forall x, (True -> True) = ( True -> f x). -Proof. - intros. reflexivity. -Qed. - -Goal forall (x:nat), x = x. -Proof. - intros. - assert (lem := lem). - (*clear ax.*) - congruence. -Qed. - diff --git a/test-suite/bugs/closed/shouldsucceed/2378.v b/test-suite/bugs/closed/shouldsucceed/2378.v deleted file mode 100644 index 7deec64d..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2378.v +++ /dev/null @@ -1,608 +0,0 @@ -(* test with Coq 8.3rc1 *) - -Require Import Program. - -Inductive Unit: Set := unit: Unit. - -Definition eq_dec T := forall x y:T, {x=y}+{x<>y}. - -Section TTS_TASM. - -Variable Time: Set. -Variable Zero: Time. -Variable tle: Time -> Time -> Prop. -Variable tlt: Time -> Time -> Prop. -Variable tadd: Time -> Time -> Time. -Variable tsub: Time -> Time -> Time. -Variable tmin: Time -> Time -> Time. -Notation "t1 @<= t2" := (tle t1 t2) (at level 70, no associativity). -Notation "t1 @< t2" := (tlt t1 t2) (at level 70, no associativity). -Notation "t1 @+ t2" := (tadd t1 t2) (at level 50, left associativity). -Notation "t1 @- t2" := (tsub t1 t2) (at level 50, left associativity). -Notation "t1 @<= t2 @<= t3" := ((tle t1 t2) /\ (tle t2 t3)) (at level 70, t2 at next level). -Notation "t1 @<= t2 @< t3" := ((tle t1 t2) /\ (tlt t2 t3)) (at level 70, t2 at next level). - -Variable tzerop: forall n, (n = Zero) + {Zero @< n}. -Variable tlt_eq_gt_dec: forall x y, {x @< y} + {x=y} + {y @< x}. -Variable tle_plus_l: forall n m, n @<= n @+ m. -Variable tle_lt_eq_dec: forall n m, n @<= m -> {n @< m} + {n = m}. - -Variable tzerop_zero: tzerop Zero = inleft (Zero @< Zero) (@eq_refl _ Zero). -Variable tplus_n_O: forall n, n @+ Zero = n. -Variable tlt_le_weak: forall n m, n @< m -> n @<= m. -Variable tlt_irrefl: forall n, ~ n @< n. -Variable tplus_nlt: forall n m, ~n @+ m @< n. -Variable tle_n: forall n, n @<= n. -Variable tplus_lt_compat_l: forall n m p, n @< m -> p @+ n @< p @+ m. -Variable tlt_trans: forall n m p, n @< m -> m @< p -> n @< p. -Variable tle_lt_trans: forall n m p, n @<= m -> m @< p -> n @< p. -Variable tlt_le_trans: forall n m p, n @< m -> m @<= p -> n @< p. -Variable tle_refl: forall n, n @<= n. -Variable tplus_le_0: forall n m, n @+ m @<= n -> m = Zero. -Variable Time_eq_dec: eq_dec Time. - -(*************************************************************) - -Section PropLogic. -Variable Predicate: Type. - -Inductive LP: Type := - LPPred: Predicate -> LP -| LPAnd: LP -> LP -> LP -| LPNot: LP -> LP. - -Variable State: Type. -Variable Sat: State -> Predicate -> Prop. - -Fixpoint lpSat st f: Prop := - match f with - LPPred p => Sat st p - | LPAnd f1 f2 => lpSat st f1 /\ lpSat st f2 - | LPNot f1 => ~lpSat st f1 - end. -End PropLogic. - -Implicit Arguments lpSat. - -Fixpoint LPTransfo Pred1 Pred2 p2lp (f: LP Pred1): LP Pred2 := - match f with - LPPred p => p2lp p - | LPAnd f1 f2 => LPAnd _ (LPTransfo Pred1 Pred2 p2lp f1) (LPTransfo Pred1 Pred2 p2lp f2) - | LPNot f1 => LPNot _ (LPTransfo Pred1 Pred2 p2lp f1) - end. -Implicit Arguments LPTransfo. - -Definition addIndex (Ind:Type) (Pred: Ind -> Type) (i: Ind) f := - LPTransfo (fun p => LPPred _ (existT (fun i => Pred i) i p)) f. - -Section TTS. - -Variable State: Type. - -Record TTS: Type := mkTTS { - Init: State -> Prop; - Delay: State -> Time -> State -> Prop; - Next: State -> State -> Prop; - Predicate: Type; - Satisfy: State -> Predicate -> Prop -}. - -Definition TTSIndexedProduct Ind (tts: Ind -> TTS): TTS := mkTTS - (fun st => forall i, Init (tts i) st) - (fun st d st' => forall i, Delay (tts i) st d st') - (fun st st' => forall i, Next (tts i) st st') - { i: Ind & Predicate (tts i) } - (fun st p => Satisfy (tts (projT1 p)) st (projT2 p)). - -End TTS. - -Section SIMU_F. - -Variables StateA StateC: Type. - -Record mapping: Type := mkMapping { - mState: Type; - mInit: StateC -> mState; - mNext: mState -> StateC -> mState; - mDelay: mState -> StateC -> Time -> mState; - mabs: mState -> StateC -> StateA -}. - -Variable m: mapping. - -Record simu (Pred: Type) (a: TTS StateA) (c: TTS StateC) (tra: Pred -> LP (Predicate _ a)) (trc: Pred -> LP (Predicate _ c)): Type := simuPrf { - inv: (mState m) -> StateC -> Prop; - invInit: forall st, Init _ c st -> inv (mInit m st) st; - invDelay: forall ex1 st1 st2 d, Delay _ c st1 d st2 -> inv ex1 st1 -> inv (mDelay m ex1 st1 d) st2; - invNext: forall ex1 st1 st2, Next _ c st1 st2 -> inv ex1 st1 -> inv (mNext m ex1 st1) st2; - simuInit: forall st, Init _ c st -> Init _ a (mabs m (mInit m st) st); - simuDelay: forall ex1 st1 st2 d, Delay _ c st1 d st2 -> inv ex1 st1 -> - Delay _ a (mabs m ex1 st1) d (mabs m (mDelay m ex1 st1 d) st2); - simuNext: forall ex1 st1 st2, Next _ c st1 st2 -> inv ex1 st1 -> - Next _ a (mabs m ex1 st1) (mabs m (mNext m ex1 st1) st2); - simuPred: forall ext st, inv ext st -> - (forall p, lpSat (Satisfy _ c) st (trc p) <-> lpSat (Satisfy _ a) (mabs m ext st) (tra p)) -}. - -Theorem satProd: forall State Ind Pred (Sat: forall i, State -> Pred i -> Prop) (st:State) i (f: LP (Pred i)), - lpSat (Sat i) st f - <-> - lpSat - (fun (st : State) (p : {i : Ind & Pred i}) => Sat (projT1 p) st (projT2 p)) st - (addIndex Ind _ i f). -Proof. - induction f; simpl; intros; split; intros; intuition. -Qed. - -Definition trProd (State: Type) Ind (Pred: Ind -> Type) (tts: Ind -> TTS State) (tr: forall i, (Pred i) -> LP (Predicate _ (tts i))): - {i:Ind & Pred i} -> LP (Predicate _ (TTSIndexedProduct _ Ind tts)) := - fun p => addIndex Ind _ (projS1 p) (tr (projS1 p) (projS2 p)). - -Implicit Arguments trProd. -Require Import Setoid. - -Theorem satTrProd: - forall State Ind Pred (tts: Ind -> TTS State) - (tr: forall i, (Pred i) -> LP (Predicate _ (tts i))) (st:State) (p: {i:Ind & (Pred i)}), - lpSat (Satisfy _ (tts (projS1 p))) st (tr (projS1 p) (projS2 p)) - <-> - lpSat (Satisfy _ (TTSIndexedProduct _ _ tts)) st (trProd _ tts tr p). -Proof. - unfold trProd, TTSIndexedProduct; simpl; intros. - rewrite (satProd State Ind (fun i => Predicate State (tts i)) - (fun i => Satisfy _ (tts i))); tauto. -Qed. - -Theorem simuProd: - forall Ind (Pred: Ind -> Type) (tta: Ind -> TTS StateA) (ttc: Ind -> TTS StateC) - (tra: forall i, (Pred i) -> LP (Predicate _ (tta i))) - (trc: forall i, (Pred i) -> LP (Predicate _ (ttc i))), - (forall i, simu _ (tta i) (ttc i) (tra i) (trc i)) -> - simu _ (TTSIndexedProduct _ Ind tta) (TTSIndexedProduct _ Ind ttc) - (trProd Pred tta tra) (trProd Pred ttc trc). -Proof. - intros. - apply simuPrf with (fun ex st => forall i, inv _ _ (ttc i) (tra i) (trc i) (X i) ex st); simpl; intros; auto. - eapply invInit; eauto. - eapply invDelay; eauto. - eapply invNext; eauto. - eapply simuInit; eauto. - eapply simuDelay; eauto. - eapply simuNext; eauto. - split; simpl; intros. - generalize (proj1 (simuPred _ _ _ _ _ (X (projS1 p)) ext st (H (projS1 p)) (projS2 p))); simpl; intro. - rewrite <- (satTrProd StateA Ind Pred tta tra); apply H1. - rewrite (satTrProd StateC Ind Pred ttc trc); apply H0. - - generalize (proj2 (simuPred _ _ _ _ _ (X (projS1 p)) ext st (H (projS1 p)) (projS2 p))); simpl; intro. - rewrite <- (satTrProd StateC Ind Pred ttc trc); apply H1. - rewrite (satTrProd StateA Ind Pred tta tra); apply H0. -Qed. - -End SIMU_F. - -Section TRANSFO. - -Record simu_equiv StateA StateC m1 m2 Pred (a: TTS StateA) (c: TTS StateC) (tra: Pred -> LP (Predicate _ a)) (trc: Pred -> LP (Predicate _ c)): Type := simuEquivPrf { - simuLR: simu StateA StateC m1 Pred a c tra trc; - simuRL: simu StateC StateA m2 Pred c a trc tra -}. - -Theorem simu_equivProd: - forall StateA StateC m1 m2 Ind (Pred: Ind -> Type) (tta: Ind -> TTS StateA) (ttc: Ind -> TTS StateC) - (tra: forall i, (Pred i) -> LP (Predicate _ (tta i))) - (trc: forall i, (Pred i) -> LP (Predicate _ (ttc i))), - (forall i, simu_equiv StateA StateC m1 m2 _ (tta i) (ttc i) (tra i) (trc i)) -> - simu_equiv StateA StateC m1 m2 _ (TTSIndexedProduct _ Ind tta) (TTSIndexedProduct _ Ind ttc) - (trProd _ _ Pred tta tra) (trProd _ _ Pred ttc trc). -Proof. - intros; split; intros. - apply simuProd; intro. - elim (X i); auto. - apply simuProd; intro. - elim (X i); auto. -Qed. - -Record RTLanguage: Type := mkRTLanguage { - Syntax: Type; - DynamicState: Syntax -> Type; - Semantic: forall (mdl:Syntax), TTS (DynamicState mdl); - MdlPredicate: Syntax -> Type; - MdlPredicateDefinition: forall mdl, MdlPredicate mdl -> LP (Predicate _ (Semantic mdl)) -}. - -Record Transformation (l1 l2: RTLanguage): Type := mkTransformation { - Tmodel: Syntax l1 -> Syntax l2; - Tl1l2: forall mdl, mapping (DynamicState l1 mdl) (DynamicState l2 (Tmodel mdl)); - Tl2l1: forall mdl, mapping (DynamicState l2 (Tmodel mdl)) (DynamicState l1 mdl); - Tpred: forall mdl, MdlPredicate l1 mdl -> LP (MdlPredicate l2 (Tmodel mdl)); - Tsim: forall mdl, simu_equiv (DynamicState l1 mdl) (DynamicState l2 (Tmodel mdl)) (Tl1l2 mdl) (Tl2l1 mdl) - (MdlPredicate l1 mdl) (Semantic l1 mdl) (Semantic l2 (Tmodel mdl)) - (MdlPredicateDefinition l1 mdl) - (fun p => LPTransfo (MdlPredicateDefinition l2 (Tmodel mdl)) (Tpred mdl p)) -}. - -Section Product. - -Record PSyntax (L: RTLanguage): Type := mkPSyntax { - pIndex: Type; - pIsEmpty: pIndex + {pIndex -> False}; - pState: Type; - pComponents: pIndex -> Syntax L; - pIsShared: forall i, DynamicState L (pComponents i) = pState -}. - -Definition pPredicate (L: RTLanguage) (sys: PSyntax L) := { i : pIndex L sys & MdlPredicate L (pComponents L sys i)}. - -(* product with shared state *) - -Definition PLanguage (L: RTLanguage): RTLanguage := - mkRTLanguage - (PSyntax L) - (pState L) - (fun mdl => TTSIndexedProduct (pState L mdl) (pIndex L mdl) - (fun i => match pIsShared L mdl i in (_ = y) return TTS y with - eq_refl => Semantic L (pComponents L mdl i) - end)) - (pPredicate L) - (fun mdl => trProd _ _ _ _ - (fun i pi => match pIsShared L mdl i as e in (_ = y) return - (LP (Predicate y - match e in (_ = y0) return (TTS y0) with - | eq_refl => Semantic L (pComponents L mdl i) - end)) - with - | eq_refl => MdlPredicateDefinition L (pComponents L mdl i) pi - end)). - -Inductive Empty: Type :=. - -Record isSharedTransfo l1 l2 tr: Prop := isSharedTransfoPrf { -sameState: forall mdl i j, - DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) = - DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl j)); -sameMState: forall mdl i j, - mState _ _ (Tl1l2 _ _ tr (pComponents l1 mdl i)) = - mState _ _ (Tl1l2 _ _ tr (pComponents l1 mdl j)); -sameM12: forall mdl i j, - Tl1l2 _ _ tr (pComponents l1 mdl i) = - match sym_eq (sameState mdl i j) in _=y return mapping _ y with - eq_refl => match sym_eq (pIsShared l1 mdl i) in _=x return mapping x _ with - eq_refl => match pIsShared l1 mdl j in _=x return mapping x _ with - eq_refl => Tl1l2 _ _ tr (pComponents l1 mdl j) - end - end - end; -sameM21: forall mdl i j, - Tl2l1 l1 l2 tr (pComponents l1 mdl i) = - match - sym_eq (sameState mdl i j) in (_ = y) - return (mapping y (DynamicState l1 (pComponents l1 mdl i))) - with eq_refl => - match - sym_eq (pIsShared l1 mdl i) in (_ = y) - return - (mapping (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl j))) y) - with - | eq_refl => - match - pIsShared l1 mdl j in (_ = y) - return - (mapping - (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl j))) y) - with - | eq_refl => Tl2l1 l1 l2 tr (pComponents l1 mdl j) - end - end -end -}. - -Definition PTransfoSyntax l1 l2 tr (h: isSharedTransfo l1 l2 tr) mdl := - mkPSyntax l2 (pIndex l1 mdl) - (pIsEmpty l1 mdl) - (match pIsEmpty l1 mdl return Type with - inleft i => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) - |inright h => pState l1 mdl - end) - (fun i => Tmodel l1 l2 tr (pComponents l1 mdl i)) - (fun i => match pIsEmpty l1 mdl as y return - (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) = - match y with - | inleft i0 => - DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i0)) - | inright _ => pState l1 mdl - end) - with - inleft j => sameState l1 l2 tr h mdl i j - | inright h => match h i with end - end). - -Definition compSemantic l mdl i := - match pIsShared l mdl i in (_=y) return TTS y with - eq_refl => Semantic l (pComponents l mdl i) - end. - -Definition compSemanticEq l mdl i s (e: DynamicState l (pComponents l mdl i) = s) := - match e in (_=y) return TTS y with - eq_refl => Semantic l (pComponents l mdl i) - end. - -Definition Pmap12 l1 l2 tr (h: isSharedTransfo l1 l2 tr) (mdl : PSyntax l1) := -match - pIsEmpty l1 mdl as s - return - (mapping (pState l1 mdl) - match s with - | inleft i => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) - | inright _ => pState l1 mdl - end) -with -| inleft p => - match - pIsShared l1 mdl p in (_ = y) - return - (mapping y (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl p)))) - with - | eq_refl => Tl1l2 l1 l2 tr (pComponents l1 mdl p) - end -| inright _ => - mkMapping (pState l1 mdl) (pState l1 mdl) Unit - (fun _ : pState l1 mdl => unit) - (fun (_ : Unit) (_ : pState l1 mdl) => unit) - (fun (_ : Unit) (_ : pState l1 mdl) (_ : Time) => unit) - (fun (_ : Unit) (X : pState l1 mdl) => X) -end. - -Definition Pmap21 l1 l2 tr (h : isSharedTransfo l1 l2 tr) mdl := -match - pIsEmpty l1 mdl as s - return - (mapping - match s with - | inleft i => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) - | inright _ => pState l1 mdl - end (pState l1 mdl)) -with -| inleft p => - match - pIsShared l1 mdl p in (_ = y) - return - (mapping (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl p))) y) - with - | eq_refl => Tl2l1 l1 l2 tr (pComponents l1 mdl p) - end -| inright _ => - mkMapping (pState l1 mdl) (pState l1 mdl) Unit - (fun _ : pState l1 mdl => unit) - (fun (_ : Unit) (_ : pState l1 mdl) => unit) - (fun (_ : Unit) (_ : pState l1 mdl) (_ : Time) => unit) - (fun (_ : Unit) (X : pState l1 mdl) => X) -end. - -Definition PTpred l1 l2 tr (h : isSharedTransfo l1 l2 tr) mdl (pp : pPredicate l1 mdl): - LP (MdlPredicate (PLanguage l2) (PTransfoSyntax l1 l2 tr h mdl)) := -match pIsEmpty l1 mdl with -| inleft _ => - let (x, p) := pp in - addIndex (pIndex l1 mdl) (fun i => MdlPredicate l2 (Tmodel l1 l2 tr (pComponents l1 mdl i))) x - (LPTransfo (Tpred l1 l2 tr (pComponents l1 mdl x)) - (LPPred (MdlPredicate l1 (pComponents l1 mdl x)) p)) -| inright f => match f (projS1 pp) with end -end. - -Lemma simu_eqA: - forall A1 A2 C m P sa sc tta ttc (h: A2=A1), - simu A1 C (match h in (_=y) return mapping _ C with eq_refl => m end) - P (match h in (_=y) return TTS y with eq_refl => sa end) - sc (fun p => match h in (_=y) return LP (Predicate y _) with eq_refl => tta p end) - ttc -> - simu A2 C m P sa sc tta ttc. -admit. -Qed. - -Lemma simu_eqC: - forall A C1 C2 m P sa sc tta ttc (h: C2=C1), - simu A C1 (match h in (_=y) return mapping A _ with eq_refl => m end) - P sa (match h in (_=y) return TTS y with eq_refl => sc end) - tta (fun p => match h in (_=y) return LP (Predicate y _) with eq_refl => ttc p end) - -> - simu A C2 m P sa sc tta ttc. -admit. -Qed. - -Lemma simu_eqA1: - forall A1 A2 C m P sa sc tta ttc (h: A1=A2), - simu A1 C m - P - (match (sym_eq h) in (_=y) return TTS y with eq_refl => sa end) sc - (fun p => match (sym_eq h) as e in (_=y) return LP (Predicate y (match e in (_=z) return TTS z with eq_refl => sa end)) with eq_refl => tta p end) ttc - -> - simu A2 C (match h in (_=y) return mapping _ C with eq_refl => m end) P sa sc tta ttc. -admit. -Qed. - -Lemma simu_eqA2: - forall A1 A2 C m P sa sc tta ttc (h: A1=A2), - simu A1 C (match (sym_eq h) in (_=y) return mapping _ C with eq_refl => m end) - P - sa sc tta ttc - -> - simu A2 C m P - (match h in (_=y) return TTS y with eq_refl => sa end) sc - (fun p => match h as e in (_=y) return LP (Predicate y match e in (_=y0) return TTS y0 with eq_refl => sa end) with eq_refl => tta p end) - ttc. -admit. -Qed. - -Lemma simu_eqC2: - forall A C1 C2 m P sa sc tta ttc (h: C1=C2), - simu A C1 (match (sym_eq h) in (_=y) return mapping A _ with eq_refl => m end) - P - sa sc tta ttc - -> - simu A C2 m P - sa (match h in (_=y) return TTS y with eq_refl => sc end) - tta (fun p => match h as e in (_=y) return LP (Predicate y match e in (_=y0) return TTS y0 with eq_refl => sc end) with eq_refl => ttc p end). -admit. -Qed. - -Lemma simu_eqM: - forall A C m1 m2 P sa sc tta ttc (h: m1=m2), - simu A C m1 P sa sc tta ttc - -> - simu A C m2 P sa sc tta ttc. -admit. -Qed. - -Lemma LPTransfo_trans: - forall Pred1 Pred2 Pred3 (tr1: Pred1 -> LP Pred2) (tr2: Pred2 -> LP Pred3) f, - LPTransfo tr2 (LPTransfo tr1 f) = LPTransfo (fun x => LPTransfo tr2 (tr1 x)) f. -Proof. - admit. -Qed. - -Lemma LPTransfo_addIndex: - forall Ind Pred tr1 x (tr2: forall i, Pred i -> LP (tr1 i)) (p: LP (Pred x)), - addIndex Ind tr1 x (LPTransfo (tr2 x) p) = - LPTransfo - (fun p0 : {i : Ind & Pred i} => - addIndex Ind tr1 (projT1 p0) (tr2 (projT1 p0) (projT2 p0))) - (addIndex Ind Pred x p). -Proof. - unfold addIndex; intros. - rewrite LPTransfo_trans. - rewrite LPTransfo_trans. - simpl. - auto. -Qed. - -Record tr_compat I0 I1 tr := compatPrf { - and_compat: forall p1 p2, tr (LPAnd I0 p1 p2) = LPAnd I1 (tr p1) (tr p2); - not_compat: forall p, tr (LPNot I0 p) = LPNot I1 (tr p) -}. - -Lemma LPTransfo_addIndex_tr: - forall Ind Pred tr0 tr1 x (tr2: forall i, Pred i -> LP (tr0 i)) (tr3: forall i, LP (tr0 i) -> LP (tr1 i)) (p: LP (Pred x)), - (forall x, tr_compat (tr0 x) (tr1 x) (tr3 x)) -> - addIndex Ind tr1 x (tr3 x (LPTransfo (tr2 x) p)) = - LPTransfo - (fun p0 : {i : Ind & Pred i} => - addIndex Ind tr1 (projT1 p0) (tr3 (projT1 p0) (tr2 (projT1 p0) (projT2 p0)))) - (addIndex Ind Pred x p). -Proof. - unfold addIndex; simpl; intros. - rewrite LPTransfo_trans; simpl. - rewrite <- LPTransfo_trans. - f_equal. - induction p; simpl; intros; auto. - rewrite (and_compat _ _ _ (H x)). - rewrite <- IHp1, <- IHp2; auto. - rewrite <- IHp. - rewrite (not_compat _ _ _ (H x)); auto. -Qed. - -Require Export Coq.Logic.FunctionalExtensionality. -Print PLanguage. -Program Definition PTransfo l1 l2 (tr: Transformation l1 l2) (h: isSharedTransfo l1 l2 tr): -Transformation (PLanguage l1) (PLanguage l2) := - mkTransformation (PLanguage l1) (PLanguage l2) - (PTransfoSyntax l1 l2 tr h) - (Pmap12 l1 l2 tr h) - (Pmap21 l1 l2 tr h) - (PTpred l1 l2 tr h) - (fun mdl => simu_equivProd - (pState l1 mdl) - (pState l2 (PTransfoSyntax l1 l2 tr h mdl)) - (Pmap12 l1 l2 tr h mdl) - (Pmap21 l1 l2 tr h mdl) - (pIndex l1 mdl) - (fun i => MdlPredicate l1 (pComponents l1 mdl i)) - (compSemantic l1 mdl) - (compSemantic l2 (PTransfoSyntax l1 l2 tr h mdl)) - _ - _ - _ - ). - -Next Obligation. - unfold compSemantic, PTransfoSyntax; simpl. - case (pIsEmpty l1 mdl); simpl; intros. - unfold pPredicate; simpl. - unfold pPredicate in X; simpl in X. - case (sameState l1 l2 tr h mdl i p). - apply (LPTransfo (MdlPredicateDefinition l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)))). - apply (LPTransfo (Tpred l1 l2 tr (pComponents l1 mdl i))). - apply (LPPred _ X). - - apply False_rect; apply (f i). -Defined. - -Next Obligation. - split; intros. - unfold Pmap12; simpl. - unfold PTransfo_obligation_1; simpl. - unfold compSemantic; simpl. - unfold eq_ind, eq_rect, f_equal; simpl. - case (pIsEmpty l1 mdl); intros. - apply simu_eqA2. - apply simu_eqC2. - apply simu_eqM with (Tl1l2 l1 l2 tr (pComponents l1 mdl i)). - apply sameM12. - apply (simuLR _ _ _ _ _ _ _ _ _ (Tsim l1 l2 tr (pComponents l1 mdl i))); intro. - - apply False_rect; apply (f i). - - unfold Pmap21; simpl. - unfold PTransfo_obligation_1; simpl. - unfold compSemantic; simpl. - unfold eq_ind, eq_rect, f_equal; simpl. - case (pIsEmpty l1 mdl); intros. - apply simu_eqC2. - apply simu_eqA2. - apply simu_eqM with (Tl2l1 l1 l2 tr (pComponents l1 mdl i)). - apply sameM21. - apply (simuRL _ _ _ _ _ _ _ _ _ (Tsim l1 l2 tr (pComponents l1 mdl i))); intro. - - apply False_rect; apply (f i). -Qed. - -Next Obligation. - unfold trProd; simpl. - unfold PTransfo_obligation_1; simpl. - unfold compSemantic; simpl. - unfold eq_ind, eq_rect, f_equal; simpl. - apply functional_extensionality; intro. - case x; clear x; intros. - unfold PTpred; simpl. - case (pIsEmpty l1 mdl); simpl; intros. - set (tr0 i := - Predicate (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i))) - (Semantic l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)))). - set (tr1 i := - Predicate (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl p))) - match sameState l1 l2 tr h mdl i p in (_ = y) return (TTS y) with - | eq_refl => Semantic l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) - end). - set (tr2 x := MdlPredicateDefinition l2 (Tmodel l1 l2 tr (pComponents l1 mdl x))). - set (Pred x := MdlPredicate l2 (Tmodel l1 l2 tr (pComponents l1 mdl x))). - set (tr3 x f := match - sameState l1 l2 tr h mdl x p as e in (_ = y) - return - (LP - (Predicate y - match e in (_ = y0) return (TTS y0) with - | eq_refl => Semantic l2 (Tmodel l1 l2 tr (pComponents l1 mdl x)) - end)) - with - | eq_refl => f - end). - apply (LPTransfo_addIndex_tr _ Pred tr0 tr1 x tr2 tr3 - (Tpred l1 l2 tr (pComponents l1 mdl x) m)). - unfold tr0, tr1, tr3; intros; split; simpl; intros; auto. - case (sameState l1 l2 tr h mdl x0 p); auto. - case (sameState l1 l2 tr h mdl x0 p); auto. - - apply False_rect; apply (f x). -Qed. - -End Product. diff --git a/test-suite/bugs/closed/shouldsucceed/2388.v b/test-suite/bugs/closed/shouldsucceed/2388.v deleted file mode 100644 index c7926711..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2388.v +++ /dev/null @@ -1,10 +0,0 @@ -(* Error message was not printed in the correct environment *) - -Fail Parameters (A:Prop) (a:A A). - -(* This is a variant (reported as part of bug #2347) *) - -Require Import EquivDec. -Fail Program Instance bool_eq_eqdec : EqDec bool eq := - {equiv_dec x y := (fix aux (x y : bool) {struct x}:= aux _ y) x y}. - diff --git a/test-suite/bugs/closed/shouldsucceed/2393.v b/test-suite/bugs/closed/shouldsucceed/2393.v deleted file mode 100644 index fb4f9261..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2393.v +++ /dev/null @@ -1,13 +0,0 @@ -Require Import Program. - -Inductive T := MkT. - -Definition sizeOf (t : T) : nat - := match t with - | MkT => 1 - end. -Variable vect : nat -> Type. -Program Fixpoint idType (t : T) (n := sizeOf t) (b : vect n) {measure n} : T - := match t with - | MkT => MkT - end. diff --git a/test-suite/bugs/closed/shouldsucceed/2404.v b/test-suite/bugs/closed/shouldsucceed/2404.v deleted file mode 100644 index fe8eba54..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2404.v +++ /dev/null @@ -1,46 +0,0 @@ -(* Check that dependencies in the indices of the type of the terms to - match are taken into account and correctly generalized *) - -Require Import Relations.Relation_Definitions. -Require Import Basics. - -Record Base := mkBase - {(* Primitives *) - World : Set - (* Names are real, links are theoretical *) - ; Name : World -> Set - - ; wweak : World -> World -> Prop - - ; exportw : forall a b : World, (wweak a b) -> (Name b) -> option (Name a) -}. - -Section Derived. - Variable base : Base. - Definition bWorld := World base. - Definition bName := Name base. - Definition bexportw := exportw base. - Definition bwweak := wweak base. - - Implicit Arguments bexportw [a b]. - -Inductive RstarSetProof {I : Type} (T : I -> I -> Type) : I -> I -> Type := - starReflS : forall a, RstarSetProof T a a -| starTransS : forall i j k, T i j -> (RstarSetProof T j k) -> RstarSetProof T i k. - -Implicit Arguments starTransS [I T i j k]. - -Definition RstarInv {A : Set} (rel : relation A) : A -> A -> Type := (flip (RstarSetProof (flip rel))). - -Definition bwweakFlip (b a : bWorld) : Prop := (bwweak a b). -Definition Rweak : forall a b : bWorld, Type := RstarInv bwweak. - -Fixpoint exportRweak {a b} (aRWb : Rweak a b) (y : bName b) : option (bName a) := - match aRWb,y with - | starReflS a, y' => Some y' - | starTransS i j k jWk jRWi, y' => - match (bexportw jWk y) with - | Some x => exportRweak jRWi x - | None => None - end - end. diff --git a/test-suite/bugs/closed/shouldsucceed/2456.v b/test-suite/bugs/closed/shouldsucceed/2456.v deleted file mode 100644 index 56f046c4..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2456.v +++ /dev/null @@ -1,53 +0,0 @@ - -Require Import Equality. - -Parameter Patch : nat -> nat -> Set. - -Inductive Catch (from to : nat) : Type - := MkCatch : forall (p : Patch from to), - Catch from to. -Implicit Arguments MkCatch [from to]. - -Inductive CatchCommute5 - : forall {from mid1 mid2 to : nat}, - Catch from mid1 - -> Catch mid1 to - -> Catch from mid2 - -> Catch mid2 to - -> Prop - := MkCatchCommute5 : - forall {from mid1 mid2 to : nat} - (p : Patch from mid1) - (q : Patch mid1 to) - (q' : Patch from mid2) - (p' : Patch mid2 to), - CatchCommute5 (MkCatch p) (MkCatch q) (MkCatch q') (MkCatch p'). - -Inductive CatchCommute {from mid1 mid2 to : nat} - (p : Catch from mid1) - (q : Catch mid1 to) - (q' : Catch from mid2) - (p' : Catch mid2 to) - : Prop - := isCatchCommute5 : forall (catchCommuteDetails : CatchCommute5 p q q' p'), - CatchCommute p q q' p'. -Notation "<< p , q >> <~> << q' , p' >>" - := (CatchCommute p q q' p') - (at level 60, no associativity). - -Lemma CatchCommuteUnique2 : - forall {from mid mid' to : nat} - {p : Catch from mid} {q : Catch mid to} - {q' : Catch from mid'} {p' : Catch mid' to} - {q'' : Catch from mid'} {p'' : Catch mid' to} - (commute1 : <> <~> <>) - (commute2 : <> <~> <>), - (p' = p'') /\ (q' = q''). -Proof with auto. -intros. -set (X := commute2). -dependent destruction commute1; -dependent destruction catchCommuteDetails; -dependent destruction commute2; -dependent destruction catchCommuteDetails generalizing X. -Admitted. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2464.v b/test-suite/bugs/closed/shouldsucceed/2464.v deleted file mode 100644 index af708587..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2464.v +++ /dev/null @@ -1,39 +0,0 @@ -Require Import FSetWeakList. -Require Import FSetDecide. - -Parameter Name : Set. -Axiom eq_Name_dec : forall (n : Name) (o : Name), {n = o} + {n <> o}. - -Module DecidableName. -Definition t := Name. -Definition eq := @eq Name. -Definition eq_refl := @refl_equal Name. -Definition eq_sym := @sym_eq Name. -Definition eq_trans := @trans_eq Name. -Definition eq_dec := eq_Name_dec. -End DecidableName. - -Module NameSetMod := Make(DecidableName). - -Module NameSetDec := WDecide (NameSetMod). - -Class PartPatchUniverse (pu_type1 pu_type2 : Type) - : Type := mkPartPatchUniverse { -}. -Class PatchUniverse {pu_type : Type} - (ppu : PartPatchUniverse pu_type pu_type) - : Type := mkPatchUniverse { - pu_nameOf : pu_type -> Name -}. - -Lemma foo : forall (pu_type : Type) - (ppu : PartPatchUniverse pu_type pu_type) - (patchUniverse : PatchUniverse ppu) - (ns ns1 ns2 : NameSetMod.t) - (containsOK : NameSetMod.Equal ns1 ns2) - (p : pu_type) - (HX1 : NameSetMod.Equal ns1 (NameSetMod.add (pu_nameOf p) ns)), - NameSetMod.Equal ns2 (NameSetMod.add (pu_nameOf p) ns). -Proof. -NameSetDec.fsetdec. -Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2467.v b/test-suite/bugs/closed/shouldsucceed/2467.v deleted file mode 100644 index ad17814a..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2467.v +++ /dev/null @@ -1,49 +0,0 @@ -(* -In the code below, I would expect the - NameSetDec.fsetdec. -to solve the Lemma, but I need to do it in steps instead. - -This is a regression relative to FSet, - -I have v8.3 (13702). -*) - -Require Import Coq.MSets.MSets. - -Parameter Name : Set. -Parameter Name_compare : Name -> Name -> comparison. -Parameter Name_compare_sym : forall {x y : Name}, - Name_compare y x = CompOpp (Name_compare x y). -Parameter Name_compare_trans : forall {c : comparison} - {x y z : Name}, - Name_compare x y = c - -> Name_compare y z = c - -> Name_compare x z = c. -Parameter Name_eq_leibniz : forall {s s' : Name}, - Name_compare s s' = Eq - -> s = s'. - -Module NameOrderedTypeAlt. -Definition t := Name. -Definition compare := Name_compare. -Definition compare_sym := @Name_compare_sym. -Definition compare_trans := @Name_compare_trans. -End NameOrderedTypeAlt. - -Module NameOrderedType := OT_from_Alt(NameOrderedTypeAlt). - -Module NameOrderedTypeWithLeibniz. -Include NameOrderedType. -Definition eq_leibniz := @Name_eq_leibniz. -End NameOrderedTypeWithLeibniz. - -Module NameSetMod := MSetList.MakeWithLeibniz(NameOrderedTypeWithLeibniz). -Module NameSetDec := WDecide (NameSetMod). - -Lemma foo : forall (xs ys : NameSetMod.t) - (n : Name) - (H1 : NameSetMod.Equal xs (NameSetMod.add n ys)), - NameSetMod.In n xs. -Proof. -NameSetDec.fsetdec. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2473.v b/test-suite/bugs/closed/shouldsucceed/2473.v deleted file mode 100644 index 4c302512..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2473.v +++ /dev/null @@ -1,39 +0,0 @@ - -Require Import Relations Program Setoid Morphisms. - -Section S1. - Variable R: nat -> relation bool. - Instance HR1: forall n, Transitive (R n). Admitted. - Instance HR2: forall n, Symmetric (R n). Admitted. - Hypothesis H: forall n a, R n (andb a a) a. - Goal forall n a b, R n b a. - intros. - (* rewrite <- H. *) (* Anomaly: Evar ?.. was not declared. Please report. *) - (* idem with setoid_rewrite *) -(* assert (HR2' := HR2 n). *) - rewrite <- H. (* ok *) - admit. - Qed. -End S1. - -Section S2. - Variable R: nat -> relation bool. - Instance HR: forall n, Equivalence (R n). Admitted. - Hypothesis H: forall n a, R n (andb a a) a. - Goal forall n a b, R n a b. - intros. rewrite <- H. admit. - Qed. -End S2. - -(* the parametrised relation is required to get the problem *) -Section S3. - Variable R: relation bool. - Instance HR1': Transitive R. Admitted. - Instance HR2': Symmetric R. Admitted. - Hypothesis H: forall a, R (andb a a) a. - Goal forall a b, R b a. - intros. - rewrite <- H. (* ok *) - admit. - Qed. -End S3. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2603.v b/test-suite/bugs/closed/shouldsucceed/2603.v deleted file mode 100644 index 371bfdc5..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2603.v +++ /dev/null @@ -1,33 +0,0 @@ -(** Namespace of module vs. namescope of definitions/constructors/... - -As noticed by A. Appel in bug #2603, module names and definition -names used to be in the same namespace. But conflict with names -of constructors (or 2nd mutual inductive...) used to not be checked -enough, leading to stange situations. - -- In 8.3pl3 we introduced checks that forbid uniformly the following - situations. - -- For 8.4 we finally managed to make module names and other names - live in two separate namespace, hence allowing all of the following - situations. -*) - -Module Type T. -End T. - -Declare Module K : T. - -Module Type L. -Declare Module E : T. -End L. - -Module M1 : L with Module E:=K. -Module E := K. -Inductive t := E. (* Used to be accepted, but End M1 below was failing *) -End M1. - -Module M2 : L with Module E:=K. -Inductive t := E. -Module E := K. (* Used to be accepted *) -End M2. (* Used to be accepted *) diff --git a/test-suite/bugs/closed/shouldsucceed/2608.v b/test-suite/bugs/closed/shouldsucceed/2608.v deleted file mode 100644 index a4c95ff9..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2608.v +++ /dev/null @@ -1,34 +0,0 @@ - -Module Type T. - Parameter Inline t : Type. -End T. - -Module M. - Definition t := nat. -End M. - -Module Make (X:T). - Include X. - - (* here t is : (Top.Make.t,Top.X.t) *) - - (* in libobject HEAD : EvalConstRef (Top.X.t,Top.X.t) - which is substituted by : {Top.X |-> Top.Make [, Top.Make.t=>Top.X.t]} - which gives : EvalConstRef (Top.Make.t,Top.X.t) *) - -End Make. - -Module P := Make M. - - (* resolver returned by add_module : Top.P.t=>inline *) - (* then constant_of_delta_kn P.t produces (Top.P.t,Top.P.t) *) - - (* in libobject HEAD : EvalConstRef (Top.Make.t,Top.X.t) - given to subst = { |-> Top.M [, Top.M.t=>inline]} - which used to give : EvalConstRef (Top.Make.t,Top.M.t) - given to subst = {Top.Make |-> Top.P [, Top.P.t=>inline]} - which used to give : EvalConstRef (Top.P.t,Top.M.t) *) - -Definition u := P.t. - (* was raising Not_found since Heads.head_map knows of (Top.P.t,Top.M.t) - and not of (Top.P.t,Top.P.t) *) diff --git a/test-suite/bugs/closed/shouldsucceed/2613.v b/test-suite/bugs/closed/shouldsucceed/2613.v deleted file mode 100644 index 4f0470b1..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2613.v +++ /dev/null @@ -1,17 +0,0 @@ -(* Check that eq_sym is still pointing to Logic.eq_sym after use of Function *) - -Require Import ZArith. -Require Recdef. - -Axiom nat_eq_dec: forall x y : nat, {x=y}+{x<>y}. - -Locate eq_sym. (* Constant Coq.Init.Logic.eq_sym *) - -Function loop (n: nat) {measure (fun x => x) n} : bool := - if nat_eq_dec n 0 then false else loop (pred n). -Proof. - admit. -Defined. - -Check eq_sym eq_refl : 0=0. - diff --git a/test-suite/bugs/closed/shouldsucceed/2615.v b/test-suite/bugs/closed/shouldsucceed/2615.v deleted file mode 100644 index 54e1a07c..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2615.v +++ /dev/null @@ -1,14 +0,0 @@ -(* This failed with an anomaly in pre-8.4 because of let-in not - properly taken into account in the test for unification pattern *) - -Inductive foo : forall A, A -> Prop := -| foo_intro : forall A x, foo A x. -Lemma bar A B f : foo (A -> B) f -> forall x : A, foo B (f x). -Fail induction 1. - -(* Whether these examples should succeed with a non-dependent return predicate - or fail because there is well-typed return predicate dependent in f - is questionable. As of 25 oct 2011, they succeed *) -refine (fun p => match p with _ => _ end). -Undo. -refine (fun p => match p with foo_intro _ _ => _ end). diff --git a/test-suite/bugs/closed/shouldsucceed/2616.v b/test-suite/bugs/closed/shouldsucceed/2616.v deleted file mode 100644 index 8758e32d..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2616.v +++ /dev/null @@ -1,7 +0,0 @@ -(* Testing ill-typed rewrite which used to succeed in 8.3 *) -Goal - forall (N : nat -> Prop) (g : nat -> sig N) (IN : forall a : sig N, a = g 0), - N 0 -> False. -Proof. -intros. -Fail rewrite IN in H. diff --git a/test-suite/bugs/closed/shouldsucceed/2629.v b/test-suite/bugs/closed/shouldsucceed/2629.v deleted file mode 100644 index 759cd3dd..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2629.v +++ /dev/null @@ -1,22 +0,0 @@ -Class Join (t: Type) : Type := mkJoin {join: t -> t -> t -> Prop}. - -Class sepalg (t: Type) {JOIN: Join t} : Type := - SepAlg { - join_eq: forall {x y z z'}, join x y z -> join x y z' -> z = z'; - join_assoc: forall {a b c d e}, join a b d -> join d c e -> - {f : t & join b c f /\ join a f e}; - join_com: forall {a b c}, join a b c -> join b a c; - join_canc: forall {a1 a2 b c}, join a1 b c -> join a2 b c -> a1=a2; - - unit_for : t -> t -> Prop := fun e a => join e a a; - join_ex_units: forall a, {e : t & unit_for e a} -}. - -Definition joins {A} `{Join A} (a b : A) : Prop := - exists c, join a b c. - -Lemma join_joins {A} `{sepalg A}: forall {a b c}, - join a b c -> joins a b. -Proof. - firstorder. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2640.v b/test-suite/bugs/closed/shouldsucceed/2640.v deleted file mode 100644 index da0cc68a..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2640.v +++ /dev/null @@ -1,17 +0,0 @@ -(* Testing consistency of globalization and interpretation in some - extreme cases *) - -Section sect. - - (* Simplification of the initial example *) - Hypothesis Other: True. - - Lemma C2 : True. - proof. - Fail have True using Other. - Abort. - - (* Variant of the same problem *) - Lemma C2 : True. - Fail clear; Other. - Abort. diff --git a/test-suite/bugs/closed/shouldsucceed/2668.v b/test-suite/bugs/closed/shouldsucceed/2668.v deleted file mode 100644 index 74c8fa34..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2668.v +++ /dev/null @@ -1,6 +0,0 @@ -Require Import MSetPositive. -Require Import MSetProperties. - -Module Pos := MSetPositive.PositiveSet. -Module PPPP := MSetProperties.WPropertiesOn(Pos). -Print Module PPPP. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2732.v b/test-suite/bugs/closed/shouldsucceed/2732.v deleted file mode 100644 index f22a8ccc..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2732.v +++ /dev/null @@ -1,19 +0,0 @@ -(* Check correct behavior of add_primitive_tactic in TACEXTEND *) - -(* Added also the case of eauto and congruence *) - -Ltac thus H := solve [H]. - -Lemma test: forall n : nat, n <= n. -Proof. - intro. - thus firstorder. - Undo. - thus eauto. -Qed. - -Lemma test2: false = true -> False. -Proof. - intro. - thus congruence. -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2733.v b/test-suite/bugs/closed/shouldsucceed/2733.v deleted file mode 100644 index fd7bd3bd..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2733.v +++ /dev/null @@ -1,26 +0,0 @@ -Definition goodid : forall {A} (x: A), A := fun A x => x. -Definition wrongid : forall A (x: A), A := fun {A} x => x. - -Inductive ty := N | B. - -Inductive alt_list : ty -> ty -> Type := - | nil {k} : alt_list k k - | Ncons {k} : nat -> alt_list B k -> alt_list N k - | Bcons {k} : bool -> alt_list N k -> alt_list B k. - -Definition trullynul k {k'} (l : alt_list k k') := -match k,l with - |N,l' => Ncons 0 (Bcons true l') - |B,l' => Bcons true (Ncons 0 l') -end. - -Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 -> -alt_list t1 t3 := - match l with - | nil _ => fun _ l2 => P l2 - | Ncons _ n l1 => fun _ l2 => Ncons n (app (@P) l1 l2) - | Bcons _ b l1 => fun _ l2 => Bcons b (app (@P) l1 l2) - end. - -Check (fun {t t'} (l: alt_list t t') => - app trullynul (goodid l) (wrongid _ nil)). diff --git a/test-suite/bugs/closed/shouldsucceed/2734.v b/test-suite/bugs/closed/shouldsucceed/2734.v deleted file mode 100644 index 826361be..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2734.v +++ /dev/null @@ -1,15 +0,0 @@ -Require Import Arith List. -Require Import OrderedTypeEx. - -Module Adr. - Include Nat_as_OT. - Definition nat2t (i: nat) : t := i. -End Adr. - -Inductive expr := Const: Adr.t -> expr. - -Inductive control := Go: expr -> control. - -Definition program := (Adr.t * (control))%type. - -Fail Definition myprog : program := (Adr.nat2t 0, Go (Adr.nat2t 0) ). \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2750.v b/test-suite/bugs/closed/shouldsucceed/2750.v deleted file mode 100644 index fc580f10..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2750.v +++ /dev/null @@ -1,23 +0,0 @@ - -Module Type ModWithRecord. - - Record foo : Type := - { A : nat - ; B : nat - }. -End ModWithRecord. - -Module Test_ModWithRecord (M : ModWithRecord). - - Definition test1 : M.foo := - {| M.A := 0 - ; M.B := 2 - |}. - - Module B := M. - - Definition test2 : M.foo := - {| M.A := 0 - ; M.B := 2 - |}. -End Test_ModWithRecord. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2817.v b/test-suite/bugs/closed/shouldsucceed/2817.v deleted file mode 100644 index 08dff992..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2817.v +++ /dev/null @@ -1,9 +0,0 @@ -(** Occur-check for Meta (up to application of already known instances) *) - -Goal forall (f: nat -> nat -> Prop) (x:bool) - (H: forall (u: nat), f u u -> True) - (H0: forall x0, f (if x then x0 else x0) x0), -False. - -intros. -Fail apply H in H0. (* should fail without exhausting the stack *) diff --git a/test-suite/bugs/closed/shouldsucceed/2836.v b/test-suite/bugs/closed/shouldsucceed/2836.v deleted file mode 100644 index a948b75e..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2836.v +++ /dev/null @@ -1,39 +0,0 @@ -(* Check that possible instantiation made during evar materialization - are taken into account and do not raise Not_found *) - -Set Implicit Arguments. - -Record SpecializedCategory (obj : Type) (Morphism : obj -> obj -> Type) := { - Object :> _ := obj; - - Identity' : forall o, Morphism o o; - Compose' : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' -}. - -Section SpecializedCategoryInterface. - Variable obj : Type. - Variable mor : obj -> obj -> Type. - Variable C : @SpecializedCategory obj mor. - - Definition Morphism (s d : C) := mor s d. - Definition Identity (o : C) : Morphism o o := C.(Identity') o. - Definition Compose (s d d' : C) (m : Morphism d d') (m0 : Morphism s d) : -Morphism s d' := C.(Compose') s d d' m m0. -End SpecializedCategoryInterface. - -Section ProductCategory. - Variable objC : Type. - Variable morC : objC -> objC -> Type. - Variable objD : Type. - Variable morD : objD -> objD -> Type. - Variable C : SpecializedCategory morC. - Variable D : SpecializedCategory morD. - -(* Should fail nicely *) -Definition ProductCategory : @SpecializedCategory (objC * objD)%type (fun s d -=> (morC (fst s) (fst d) * morD (snd s) (snd d))%type). -Fail refine {| - Identity' := (fun o => (Identity (fst o), Identity (snd o))); - Compose' := (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd -m2) (snd m1))) - |}. diff --git a/test-suite/bugs/closed/shouldsucceed/2837.v b/test-suite/bugs/closed/shouldsucceed/2837.v deleted file mode 100644 index 5d984463..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2837.v +++ /dev/null @@ -1,15 +0,0 @@ -Require Import JMeq. - -Axiom test : forall n m : nat, JMeq n m. - -Goal forall n m : nat, JMeq n m. - -(* I) with no intros nor variable hints, this should produce a regular error - instead of Uncaught exception Failure("nth"). *) -Fail rewrite test. - -(* II) with intros but indication of variables, still an error *) -Fail (intros; rewrite test). - -(* III) a working variant: *) -intros; rewrite (test n m). \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2928.v b/test-suite/bugs/closed/shouldsucceed/2928.v deleted file mode 100644 index 21e92ae2..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2928.v +++ /dev/null @@ -1,11 +0,0 @@ -Class Equiv A := equiv: A -> A -> Prop. -Infix "=" := equiv : type_scope. - -Class Associative {A} f `{Equiv A} := associativity x y z : f x (f y z) = f (f x y) z. - -Class SemiGroup A op `{Equiv A} := { sg_ass :>> Associative op }. - -Class SemiLattice A op `{Equiv A} := - { semilattice_sg :>> SemiGroup A op - ; redundant : Associative op - }. diff --git a/test-suite/bugs/closed/shouldsucceed/2983.v b/test-suite/bugs/closed/shouldsucceed/2983.v deleted file mode 100644 index 15598352..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2983.v +++ /dev/null @@ -1,8 +0,0 @@ -Module Type ModA. -End ModA. -Module Type ModB(A : ModA). -End ModB. -Module Foo(A : ModA)(B : ModB A). -End Foo. - -Print Module Foo. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2995.v b/test-suite/bugs/closed/shouldsucceed/2995.v deleted file mode 100644 index ba3acd08..00000000 --- a/test-suite/bugs/closed/shouldsucceed/2995.v +++ /dev/null @@ -1,9 +0,0 @@ -Module Type Interface. - Parameter error: nat. -End Interface. - -Module Implementation <: Interface. - Definition t := bool. - Definition error: t := false. -Fail End Implementation. -(* A UserError here is expected, not an uncaught Not_found *) \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/3000.v b/test-suite/bugs/closed/shouldsucceed/3000.v deleted file mode 100644 index 27de34ed..00000000 --- a/test-suite/bugs/closed/shouldsucceed/3000.v +++ /dev/null @@ -1,2 +0,0 @@ -Inductive t (t':Type) : Type := A | B. -Definition d := match t with _ => 1 end. (* used to fail on list_chop *) diff --git a/test-suite/bugs/closed/shouldsucceed/3004.v b/test-suite/bugs/closed/shouldsucceed/3004.v deleted file mode 100644 index 896b1958..00000000 --- a/test-suite/bugs/closed/shouldsucceed/3004.v +++ /dev/null @@ -1,7 +0,0 @@ -Set Implicit Arguments. -Unset Strict Implicit. -Parameter (M : nat -> Type). -Parameter (mp : forall (T1 T2 : Type) (f : T1 -> T2), list T1 -> list T2). - -Definition foo (s : list {n : nat & M n}) := - let exT := existT in mp (fun x => projT1 x) s. diff --git a/test-suite/bugs/closed/shouldsucceed/3008.v b/test-suite/bugs/closed/shouldsucceed/3008.v deleted file mode 100644 index 3f3a979a..00000000 --- a/test-suite/bugs/closed/shouldsucceed/3008.v +++ /dev/null @@ -1,29 +0,0 @@ -Module Type Intf1. -Parameter T : Type. -Inductive a := A. -End Intf1. - -Module Impl1 <: Intf1. -Definition T := unit. -Inductive a := A. -End Impl1. - -Module Type Intf2 - (Impl1 : Intf1). -Parameter x : Impl1.A=Impl1.A -> Impl1.T. -End Intf2. - -Module Type Intf3 - (Impl1 : Intf1) - (Impl2 : Intf2(Impl1)). -End Intf3. - -Fail Module Toto - (Impl1' : Intf1) - (Impl2 : Intf2(Impl1')) - (Impl3 : Intf3(Impl1)(Impl2)). -(* A UserError is expected here, not an uncaught Not_found *) - -(* NB : the Inductive above and the A=A weren't in the initial test, - they are here only to force an access to the environment - (cf [Printer.qualid_of_global]) and check that this env is ok. *) \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/335.v b/test-suite/bugs/closed/shouldsucceed/335.v deleted file mode 100644 index 166fa7a9..00000000 --- a/test-suite/bugs/closed/shouldsucceed/335.v +++ /dev/null @@ -1,5 +0,0 @@ -(* Compatibility of Require with backtracking at interactive module end *) - -Module A. -Require List. -End A. diff --git a/test-suite/bugs/closed/shouldsucceed/348.v b/test-suite/bugs/closed/shouldsucceed/348.v deleted file mode 100644 index 28cc5cb1..00000000 --- a/test-suite/bugs/closed/shouldsucceed/348.v +++ /dev/null @@ -1,13 +0,0 @@ -Module Type S. - Parameter empty: Set. -End S. - -Module D (M:S). - Import M. - Definition empty:=nat. -End D. - -Module D' (M:S). - Import M. - Definition empty:Set. exact nat. Save. -End D'. diff --git a/test-suite/bugs/closed/shouldsucceed/38.v b/test-suite/bugs/closed/shouldsucceed/38.v deleted file mode 100644 index 4fc8d7c9..00000000 --- a/test-suite/bugs/closed/shouldsucceed/38.v +++ /dev/null @@ -1,22 +0,0 @@ -Require Import Setoid. - -Variable A : Set. - -Inductive liste : Set := -| vide : liste -| c : A -> liste -> liste. - -Inductive e : A -> liste -> Prop := -| ec : forall (x : A) (l : liste), e x (c x l) -| ee : forall (x y : A) (l : liste), e x l -> e x (c y l). - -Definition same := fun (l m : liste) => forall (x : A), e x l <-> e x m. - -Definition same_refl (x:liste) : (same x x). - unfold same; split; intros; trivial. -Save. - -Goal forall (x:liste), (same x x). - intro. - apply (same_refl x). -Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/545.v b/test-suite/bugs/closed/shouldsucceed/545.v deleted file mode 100644 index 926af7dd..00000000 --- a/test-suite/bugs/closed/shouldsucceed/545.v +++ /dev/null @@ -1,5 +0,0 @@ -Require Export Reals. - -Parameter toto : nat -> nat -> nat. - -Notation " e # f " := (toto e f) (at level 30, f at level 0). diff --git a/test-suite/bugs/closed/shouldsucceed/808_2411.v b/test-suite/bugs/closed/shouldsucceed/808_2411.v deleted file mode 100644 index 1c13e745..00000000 --- a/test-suite/bugs/closed/shouldsucceed/808_2411.v +++ /dev/null @@ -1,27 +0,0 @@ -Section test. -Variable n:nat. -Lemma foo: 0 <= n. -Proof. -(* declaring an Axiom during a proof makes it immediatly - usable, juste as a full Definition. *) -Axiom bar : n = 1. -rewrite bar. -now apply le_S. -Qed. - -Lemma foo' : 0 <= n. -Proof. -(* Declaring an Hypothesis during a proof is ok, - but this hypothesis won't be usable by the current proof(s), - only by later ones. *) -Hypothesis bar' : n = 1. -Fail rewrite bar'. -Abort. - -Lemma foo'' : 0 <= n. -Proof. -rewrite bar'. -now apply le_S. -Qed. - -End test. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/846.v b/test-suite/bugs/closed/shouldsucceed/846.v deleted file mode 100644 index ee5ec1fa..00000000 --- a/test-suite/bugs/closed/shouldsucceed/846.v +++ /dev/null @@ -1,213 +0,0 @@ -Set Implicit Arguments. - -Open Scope type_scope. - -Inductive One : Set := inOne: One. - -Definition maybe: forall A B:Set,(A -> B) -> One + A -> One + B. -Proof. - intros A B f c. - case c. - left; assumption. - right; apply f; assumption. -Defined. - -Definition id (A:Set)(a:A):=a. - -Definition LamF (X: Set -> Set)(A:Set) :Set := - A + (X A)*(X A) + X(One + A). - -Definition LamF' (X: Set -> Set)(A:Set) :Set := - LamF X A. - -Require Import List. -Require Import Bool. - -Definition index := list bool. - -Inductive L (A:Set) : index -> Set := - initL: A -> L A nil - | pluslL: forall l:index, One -> L A (false::l) - | plusrL: forall l:index, L A l -> L A (false::l) - | varL: forall l:index, L A l -> L A (true::l) - | appL: forall l:index, L A (true::l) -> L A (true::l) -> L A (true::l) - | absL: forall l:index, L A (true::false::l) -> L A (true::l). - -Scheme L_rec_simp := Minimality for L Sort Set. - -Definition Lam' (A:Set) := L A (true::nil). - -Definition aczelapp: forall (l1 l2: index)(A:Set), L (L A l2) l1 -> L A - (l1++l2). -Proof. - intros l1 l2 A. - generalize l1. - clear l1. - (* Check (fun i:index => L A (i++l2)). *) - apply (L_rec_simp (A:=L A l2) (fun i:index => L A (i++l2))). - trivial. - intros l o. - simpl app. - apply pluslL; assumption. - intros l _ t. - simpl app. - apply plusrL; assumption. - intros l _ t. - simpl app. - apply varL; assumption. - intros l _ t1 _ t2. - simpl app in *|-*. - Check 0. - apply appL; [exact t1| exact t2]. - intros l _ t. - simpl app in *|-*. - Check 0. - apply absL; assumption. -Defined. - -Definition monL: forall (l:index)(A:Set)(B:Set), (A->B) -> L A l -> L B l. -Proof. - intros l A B f. - intro t. - elim t. - intro a. - exact (initL (f a)). - intros i u. - exact (pluslL _ _ u). - intros i _ r. - exact (plusrL r). - intros i _ r. - exact (varL r). - intros i _ r1 _ r2. - exact (appL r1 r2). - intros i _ r. - exact (absL r). -Defined. - -Definition lam': forall (A B:Set), (A -> B) -> Lam' A -> Lam' B. -Proof. - intros A B f t. - unfold Lam' in *|-*. - Check 0. - exact (monL f t). -Defined. - -Definition inLam': forall A:Set, LamF' Lam' A -> Lam' A. -Proof. - intros A [[a|[t1 t2]]|r]. - unfold Lam'. - exact (varL (initL a)). - exact (appL t1 t2). - unfold Lam' in * |- *. - Check 0. - apply absL. - change (L A ((true::nil) ++ (false::nil))). - apply aczelapp. - (* Check (fun x:One + A => (match (maybe (fun a:A => initL a) x) with - | inl u => pluslL _ _ u - | inr t' => plusrL t' end)). *) - exact (monL (fun x:One + A => - (match (maybe (fun a:A => initL a) x) with - | inl u => pluslL _ _ u - | inr t' => plusrL t' end)) r). -Defined. - -Section minimal. - -Definition sub1 (F G: Set -> Set):= forall A:Set, F A->G A. -Hypothesis G: Set -> Set. -Hypothesis step: sub1 (LamF' G) G. - -Fixpoint L'(A:Set)(i:index){struct i} : Set := - match i with - nil => A - | false::l => One + L' A l - | true::l => G (L' A l) - end. - -Definition LinL': forall (A:Set)(i:index), L A i -> L' A i. -Proof. - intros A i t. - elim t. - intro a. - unfold L'. - assumption. - intros l u. - left; assumption. - intros l _ r. - right; assumption. - intros l _ r. - apply (step (A:=L' A l)). - exact (inl _ (inl _ r)). - intros l _ r1 _ r2. - apply (step (A:=L' A l)). - (* unfold L' in * |- *. - Check 0. *) - exact (inl _ (inr _ (pair r1 r2))). - intros l _ r. - apply (step (A:=L' A l)). - exact (inr _ r). -Defined. - -Definition L'inG: forall A: Set, L' A (true::nil) -> G A. -Proof. - intros A t. - unfold L' in t. - assumption. -Defined. - -Definition Itbasic: sub1 Lam' G. -Proof. - intros A t. - apply L'inG. - unfold Lam' in t. - exact (LinL' t). -Defined. - -End minimal. - -Definition recid := Itbasic inLam'. - -Definition L'Lam'inL: forall (i:index)(A:Set), L' Lam' A i -> L A i. -Proof. - intros i A t. - induction i. - unfold L' in t. - apply initL. - assumption. - induction a. - simpl L' in t. - apply (aczelapp (l1:=true::nil) (l2:=i)). - exact (lam' IHi t). - simpl L' in t. - induction t. - exact (pluslL _ _ a). - exact (plusrL (IHi b)). -Defined. - - -Lemma recidgen: forall(A:Set)(i:index)(t:L A i), L'Lam'inL i A (LinL' inLam' t) - = t. -Proof. - intros A i t. - induction t. - trivial. - trivial. - simpl. - rewrite IHt. - trivial. - simpl L'Lam'inL. - rewrite IHt. - trivial. - simpl L'Lam'inL. - simpl L'Lam'inL in IHt1. - unfold lam' in IHt1. - simpl L'Lam'inL in IHt2. - unfold lam' in IHt2. - - (* going on. This fails for the original solution. *) - rewrite IHt1. - rewrite IHt2. - trivial. -Abort. (* one goal still left *) - diff --git a/test-suite/bugs/closed/shouldsucceed/931.v b/test-suite/bugs/closed/shouldsucceed/931.v deleted file mode 100644 index 21f15e72..00000000 --- a/test-suite/bugs/closed/shouldsucceed/931.v +++ /dev/null @@ -1,7 +0,0 @@ -Parameter P : forall n : nat, n=n -> Prop. - -Goal Prop. - refine (P _ _). - instantiate (1:=0). - trivial. -Qed. diff --git a/test-suite/bugs/opened/1338.v-disabled b/test-suite/bugs/opened/1338.v-disabled new file mode 100644 index 00000000..ab0f9820 --- /dev/null +++ b/test-suite/bugs/opened/1338.v-disabled @@ -0,0 +1,12 @@ +Require Import Omega. + +Goal forall x, 0 <= x -> x <= 20 -> +x <> 0 + -> x <> 1 -> x <> 2 -> x <> 3 -> x <>4 -> x <> 5 -> x <> 6 -> x <> 7 -> x <> 8 +-> x <> 9 -> x <> 10 + -> x <> 11 -> x <> 12 -> x <> 13 -> x <> 14 -> x <> 15 -> x <> 16 -> x <> 17 +-> x <> 18 -> x <> 19 -> x <> 20 -> False. +Proof. + intros. + Fail omega. +Abort. diff --git a/test-suite/bugs/opened/1501.v b/test-suite/bugs/opened/1501.v new file mode 100644 index 00000000..b36f21da --- /dev/null +++ b/test-suite/bugs/opened/1501.v @@ -0,0 +1,96 @@ +Set Implicit Arguments. + + +Require Export Relation_Definitions. +Require Export Setoid. + + +Section Essais. + +(* Parametrized Setoid *) +Parameter K : Type -> Type. +Parameter equiv : forall A : Type, K A -> K A -> Prop. +Parameter equiv_refl : forall (A : Type) (x : K A), equiv x x. +Parameter equiv_sym : forall (A : Type) (x y : K A), equiv x y -> equiv y x. +Parameter equiv_trans : forall (A : Type) (x y z : K A), equiv x y -> equiv y z +-> equiv x z. + +(* basic operations *) +Parameter val : forall A : Type, A -> K A. +Parameter bind : forall A B : Type, K A -> (A -> K B) -> K B. + +Parameter + bind_compat : + forall (A B : Type) (m1 m2 : K A) (f1 f2 : A -> K B), + equiv m1 m2 -> + (forall x : A, equiv (f1 x) (f2 x)) -> equiv (bind m1 f1) (bind m2 f2). + +(* monad axioms *) +Parameter + bind_val_l : + forall (A B : Type) (a : A) (f : A -> K B), equiv (bind (val a) f) (f a). +Parameter + bind_val_r : + forall (A : Type) (m : K A), equiv (bind m (fun a => val a)) m. +Parameter + bind_assoc : + forall (A B C : Type) (m : K A) (f : A -> K B) (g : B -> K C), + equiv (bind (bind m f) g) (bind m (fun a => bind (f a) g)). + + +Hint Resolve equiv_refl equiv_sym equiv_trans: monad. + +Instance equiv_rel A: Equivalence (@equiv A). +Proof. + constructor. + intros xa; apply equiv_refl. + intros xa xb; apply equiv_sym. + intros xa xb xc; apply equiv_trans. +Defined. + +Definition fequiv (A B: Type) (f g: A -> K B) := forall (x:A), (equiv (f x) (g +x)). + +Lemma fequiv_refl : forall (A B: Type) (f : A -> K B), fequiv f f. +Proof. + unfold fequiv; auto with monad. +Qed. + +Lemma fequiv_sym : forall (A B: Type) (x y : A -> K B), fequiv x y -> fequiv y +x. +Proof. + unfold fequiv; auto with monad. +Qed. + +Lemma fequiv_trans : forall (A B: Type) (x y z : A -> K B), fequiv x y -> +fequiv +y z -> fequiv x z. +Proof. + unfold fequiv; intros; eapply equiv_trans; auto with monad. +Qed. + +Instance fequiv_re A B: Equivalence (@fequiv A B). +Proof. + constructor. + intros f; apply fequiv_refl. + intros f g; apply fequiv_sym. + intros f g h; apply fequiv_trans. +Defined. + +Instance bind_mor A B: Morphisms.Proper (@equiv _ ==> @fequiv _ _ ==> @equiv _) (@bind A B). +Proof. + unfold fequiv; intros x y xy_equiv f g fg_equiv; apply bind_compat; auto. +Qed. + +Lemma test: + forall (A B: Type) (m1 m2 m3: K A) (f: A -> A -> K B), + (equiv m1 m2) -> (equiv m2 m3) -> + equiv (bind m1 (fun a => bind m2 (fun a' => f a a'))) + (bind m2 (fun a => bind m3 (fun a' => f a a'))). +Proof. + intros A B m1 m2 m3 f H1 H2. + setoid_rewrite H1. (* this works *) + Fail setoid_rewrite H2. +Abort. +(* trivial by equiv_refl. +Qed.*) diff --git a/test-suite/bugs/opened/1596.v b/test-suite/bugs/opened/1596.v new file mode 100644 index 00000000..7c5dc416 --- /dev/null +++ b/test-suite/bugs/opened/1596.v @@ -0,0 +1,261 @@ +Require Import Relations. +Require Import FSets. +Require Import Arith. +Require Import Omega. +Unset Standard Proposition Elimination Names. + +Set Keyed Unification. + +Lemma Bool_elim_bool : forall (b:bool),b=true \/ b=false. + destruct b;try tauto. +Qed. + +Module OrderedPair (X:OrderedType) (Y:OrderedType) <: OrderedType with +Definition t := (X.t * Y.t)%type. + Definition t := (X.t * Y.t)%type. + + Definition eq (xy1:t) (xy2:t) := + let (x1,y1) := xy1 in + let (x2,y2) := xy2 in + (X.eq x1 x2) /\ (Y.eq y1 y2). + + Definition lt (xy1:t) (xy2:t) := + let (x1,y1) := xy1 in + let (x2,y2) := xy2 in + (X.lt x1 x2) \/ ((X.eq x1 x2) /\ (Y.lt y1 y2)). + + Lemma eq_refl : forall (x:t),(eq x x). + destruct x. + unfold eq. + split;[apply X.eq_refl | apply Y.eq_refl]. + Qed. + + Lemma eq_sym : forall (x y:t),(eq x y)->(eq y x). + destruct x;destruct y;unfold eq;intro. + elim H;clear H;intros. + split;[apply X.eq_sym | apply Y.eq_sym];trivial. + Qed. + + Lemma eq_trans : forall (x y z:t),(eq x y)->(eq y z)->(eq x z). + unfold eq;destruct x;destruct y;destruct z;intros. + elim H;clear H;intros. + elim H0;clear H0;intros. + split;[eapply X.eq_trans | eapply Y.eq_trans];eauto. + Qed. + + Lemma lt_trans : forall (x y z:t),(lt x y)->(lt y z)->(lt x z). + unfold lt;destruct x;destruct y;destruct z;intros. + case H;clear H;intro. + case H0;clear H0;intro. + left. + eapply X.lt_trans;eauto. + elim H0;clear H0;intros. + left. + case (X.compare t0 t4);trivial;intros. + generalize (X.eq_sym H0);intro. + generalize (X.eq_trans e H2);intro. + elim (X.lt_not_eq H H3). + generalize (X.lt_trans l H);intro. + generalize (X.eq_sym H0);intro. + elim (X.lt_not_eq H2 H3). + elim H;clear H;intros. + case H0;clear H0;intro. + left. + case (X.compare t0 t4);trivial;intros. + generalize (X.eq_sym H);intro. + generalize (X.eq_trans H2 e);intro. + elim (X.lt_not_eq H0 H3). + generalize (X.lt_trans H0 l);intro. + generalize (X.eq_sym H);intro. + elim (X.lt_not_eq H2 H3). + elim H0;clear H0;intros. + right. + split. + eauto. + eauto. + Qed. + + Lemma lt_not_eq : forall (x y:t),(lt x y)->~(eq x y). + unfold lt, eq;destruct x;destruct y;intro;intro. + elim H0;clear H0;intros. + case H. + intro. + apply (X.lt_not_eq H2 H0). + intro. + elim H2;clear H2;intros. + apply (Y.lt_not_eq H3 H1). + Qed. + + Definition compare : forall (x y:t),(Compare lt eq x y). + destruct x;destruct y. + case (X.compare t0 t2);intro. + apply LT. + left;trivial. + case (Y.compare t1 t3);intro. + apply LT. + right. + tauto. + apply EQ. + split;trivial. + apply GT. + right;auto. + apply GT. + left;trivial. + Defined. + + Definition eq_dec : forall (x y: t), { eq x y } + { ~ eq x y}. + Proof. + intros [xa xb] [ya yb]; simpl. + destruct (X.eq_dec xa ya). + destruct (Y.eq_dec xb yb). + + left; now split. + + right. now intros [eqa eqb]. + + right. now intros [eqa eqb]. + Defined. + + Hint Immediate eq_sym. + Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. +End OrderedPair. + +Module MessageSpi. + Inductive message : Set := + | MNam : nat -> message. + + Definition t := message. + + Fixpoint message_lt (m n:message) {struct m} : Prop := + match (m,n) with + | (MNam n1,MNam n2) => n1 < n2 + end. + + Module Ord <: OrderedType with Definition t := message with Definition eq := +@eq message. + Definition t := message. + Definition eq := @eq message. + Definition lt := message_lt. + + Lemma eq_refl : forall (x:t),eq x x. + unfold eq;auto. + Qed. + + Lemma eq_sym : forall (x y:t),(eq x y )->(eq y x). + unfold eq;auto. + Qed. + + Lemma eq_trans : forall (x y z:t),(eq x y)->(eq y z)->(eq x z). + unfold eq;auto;intros;congruence. + Qed. + + Lemma lt_trans : forall (x y z:t),(lt x y)->(lt y z)->(lt x z). + unfold lt. + induction x;destruct y;simpl;try tauto;destruct z;try tauto;intros. + omega. + Qed. + + Lemma lt_not_eq : forall (x y:t),(lt x y)->~(eq x y). + unfold eq;unfold lt. + induction x;destruct y;simpl;try tauto;intro;red;intro;try (discriminate +H0);injection H0;intros. + elim (lt_irrefl n);try omega. + Qed. + + Definition compare : forall (x y:t),(Compare lt eq x y). + unfold lt, eq. + induction x;destruct y;intros;try (apply LT;simpl;trivial;fail);try +(apply +GT;simpl;trivial;fail). + case (lt_eq_lt_dec n n0);intros;try (case s;clear s;intros). + apply LT;trivial. + apply EQ;trivial. + rewrite e;trivial. + apply GT;trivial. + Defined. + + Definition eq_dec : forall (x y: t), { eq x y } + { ~ eq x y}. + Proof. + intros [i] [j]. unfold eq. + destruct (eq_nat_dec i j). + + left. now f_equal. + + right. intros meq; now inversion meq. + Defined. + + Hint Immediate eq_sym. + Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. + End Ord. + + Theorem eq_dec : forall (m n:message),{m=n}+{~(m=n)}. + intros. + case (Ord.compare m n);intro;[right | left | right];try (red;intro). + elim (Ord.lt_not_eq m n);auto. + rewrite e;auto. + elim (Ord.lt_not_eq n m);auto. + Defined. +End MessageSpi. + +Module MessagePair := OrderedPair MessageSpi.Ord MessageSpi.Ord. + +Module Type Hedge := FSetInterface.S with Module E := MessagePair. + +Module A (H:Hedge). + Definition hedge := H.t. + + Definition message_relation := relation MessageSpi.message. + + Definition relation_of_hedge (h:hedge) (m n:MessageSpi.message) := H.In (m,n) +h. + + Inductive hedge_synthesis_relation (h:message_relation) : message_relation := + | SynInc : forall (m n:MessageSpi.message),(h m +n)->(hedge_synthesis_relation h m n). + + Fixpoint hedge_in_synthesis (h:hedge) (m:MessageSpi.message) +(n:MessageSpi.message) {struct m} : bool := + if H.mem (m,n) h + then true + else false. + + Definition hedge_synthesis_spec (h:hedge) := hedge_synthesis_relation +(relation_of_hedge h). + + Lemma hedge_in_synthesis_impl_hedge_synthesis_spec : forall (h:hedge),forall +(m n:MessageSpi.message),(hedge_in_synthesis h m n)=true->(hedge_synthesis_spec +h m n). + unfold hedge_synthesis_spec;unfold relation_of_hedge. + induction m;simpl;intro. + elim (Bool_elim_bool (H.mem (MessageSpi.MNam n,n0) h));intros. + apply SynInc;apply H.mem_2;trivial. + rewrite H in H0. (* !! possible here !! *) + discriminate H0. + Qed. +End A. + +Module B (H:Hedge). + Definition hedge := H.t. + + Definition message_relation := relation MessageSpi.t. + + Definition relation_of_hedge (h:hedge) (m n:MessageSpi.t) := H.In (m,n) h. + + Inductive hedge_synthesis_relation (h:message_relation) : message_relation := + | SynInc : forall (m n:MessageSpi.t),(h m n)->(hedge_synthesis_relation h m +n). + + Fixpoint hedge_in_synthesis (h:hedge) (m:MessageSpi.t) (n:MessageSpi.t) +{struct m} : bool := + if H.mem (m,n) h + then true + else false. + + Definition hedge_synthesis_spec (h:hedge) := hedge_synthesis_relation +(relation_of_hedge h). + + Lemma hedge_in_synthesis_impl_hedge_synthesis_spec : forall (h:hedge),forall +(m n:MessageSpi.t),(hedge_in_synthesis h m n)=true->(hedge_synthesis_spec h m +n). + unfold hedge_synthesis_spec;unfold relation_of_hedge. + induction m;simpl;intro. + elim (Bool_elim_bool (H.mem (MessageSpi.MNam n,n0) h));intros. + apply SynInc;apply H.mem_2;trivial. + rewrite H in H0. discriminate. (* !! impossible here !! *) + Qed. +End B. \ No newline at end of file diff --git a/test-suite/bugs/opened/1671.v b/test-suite/bugs/opened/1671.v new file mode 100644 index 00000000..b4e653f6 --- /dev/null +++ b/test-suite/bugs/opened/1671.v @@ -0,0 +1,12 @@ +(* Exemple soumis par Pierre Corbineau (bug #1671) *) + +CoInductive hdlist : unit -> Type := +| cons : hdlist tt -> hdlist tt. + +Variable P : forall bo, hdlist bo -> Prop. +Variable all : forall bo l, P bo l. + +Fail Definition F (l:hdlist tt) : P tt l := +match l in hdlist u return P u l with +| cons (cons l') => all tt _ +end. diff --git a/test-suite/bugs/opened/1773.v b/test-suite/bugs/opened/1773.v deleted file mode 100644 index 4aabf19c..00000000 --- a/test-suite/bugs/opened/1773.v +++ /dev/null @@ -1,10 +0,0 @@ -Goal forall B C : nat -> nat -> Prop, forall k, C 0 k -> - (exists A, (forall k', C A k' -> B A k') -> B A k). -Proof. - intros B C k H. - econstructor. - intros X. - apply X. - apply H. -Qed. - diff --git a/test-suite/bugs/opened/1811.v b/test-suite/bugs/opened/1811.v new file mode 100644 index 00000000..10c988fc --- /dev/null +++ b/test-suite/bugs/opened/1811.v @@ -0,0 +1,10 @@ +Require Export Bool. + +Lemma neg2xor : forall b, xorb true b = negb b. +Proof. auto. Qed. + +Goal forall b1 b2, (negb b1 = b2) -> xorb true b1 = b2. +Proof. + intros b1 b2. + Fail rewrite neg2xor. +Abort. \ No newline at end of file diff --git a/test-suite/bugs/opened/2572.v-disabled b/test-suite/bugs/opened/2572.v-disabled new file mode 100644 index 00000000..3f6c6a0d --- /dev/null +++ b/test-suite/bugs/opened/2572.v-disabled @@ -0,0 +1,187 @@ +Require Import List. +Definition is_dec (P:Prop) := {P}+{~P}. +Definition eq_dec (T:Type) := forall (t1 t2:T), is_dec (t1=t2). + +Record Label : Type := mkLabel { + LabElem: Type; + LabProd: LabElem -> LabElem -> option LabElem; + LabBot: LabElem -> Prop; + LabError: LabElem -> Prop +}. + +Definition LProd (L1 L2: Label): Label := {| + LabElem := LabElem L1 * LabElem L2; + LabProd := fun lg ld => let (lg1,lg2) := lg in let (ld1,ld2) := ld in + match LabProd L1 lg1 ld1, LabProd L2 lg2 ld2 with + Some g, Some d => Some (g,d) + | _,_ => None + end; + LabBot l := let (l1,l2) := l in LabBot L1 l1 \/ LabBot L2 l2; + LabError l := let (l1,l2) := l in LabError L1 l1 \/ LabError L2 l2 +|}. + +Definition Lrestrict (L: Label) (S: LabElem L -> bool): Label := {| + LabElem := LabElem L; + LabProd l1 l2 := if andb (S l1) (S l2) then LabProd L l1 l2 else None; + LabBot l := LabBot L l; + LabError l := LabError L l +|}. + +Notation "l1 ^* l2" := (LProd l1 l2) (at level 50). + +Record LTS(L:Type): Type := mkLTS { + State: Type; + Init: State -> Prop; + Next: State -> L -> State -> Prop +}. +Implicit Arguments State. +Implicit Arguments Init. +Implicit Arguments Next. + +Definition sound L (S: LTS (LabElem L)): Prop := + forall s s' l, Next S s l s' -> ~LabError L l. + +Inductive PNext L (S1 S2:LTS (LabElem L)): State S1 * State S2 -> (LabElem L) -> State S1 * State S2 -> Prop := + LNext: forall s1 s2 l1 s'1, Next S1 s1 l1 s'1 -> (forall l2, LabProd L l1 l2 = None) -> + PNext L S1 S2 (s1,s2) l1 (s'1,s2) +| RNext: forall s1 s2 l2 s'2, (forall l1, LabProd L l1 l2 = None) -> Next S2 s2 l2 s'2 -> + PNext L S1 S2 (s1,s2) l2 (s1,s'2) +| SNext: forall s1 s2 l1 l2 l s'1 s'2, Next S1 s1 l1 s'1 -> Next S2 s2 l2 s'2 -> + Some l = LabProd L l1 l2 -> PNext L S1 S2 (s1,s2) l (s'1,s'2). + +Definition Produit (L:Label) (S1 S2: LTS (LabElem L)): LTS (LabElem L) := {| + State := State S1 * State S2; + Init := fun s => let (s1,s2) := s in Init S1 s1 /\ Init S2 s2; + Next :=PNext L S1 S2 +|}. + +Parameter Time: Type. +Parameter teq: forall t1 t2:Time, {t1=t2}+{t1<>t2}. + +Inductive TLabElem(L:Type): Type := + Tdiscrete: L -> TLabElem L +| Tdelay: Time -> TLabElem L +| Tbot: TLabElem L. + +Definition TLabel L: Label := {| + LabElem := TLabElem (LabElem L); + LabProd lt1 lt2 := + match lt1, lt2 with + Tdiscrete l1, Tdiscrete l2 => match (LabProd L l1 l2) with Some l => Some (Tdiscrete (LabElem L) l) | None => None end + | Tdelay t1, Tdelay t2 => if teq t1 t2 then Some (Tdelay (LabElem L) t1) else Some (Tbot (LabElem L)) + | _,_ => None + end; + LabBot lt := match lt with + Tdiscrete l => LabBot L l + | Tbot => True + | _ => False + end; + LabError lt := match lt with + Tdiscrete l => LabError L l + | _ => False + end + |}. + +Parameter Var: Type. +Parameter allv: forall P, (forall (v:Var), is_dec (P v)) -> is_dec (forall v, P v). +Parameter DType: Type. +Parameter Data: DType -> Type. +Parameter vtype: Var -> DType. +Parameter Deq: forall t (d1 d2: Data t), is_dec (d1=d2). + +Inductive Vctr(v:Var): Type := + Wctr: Data (vtype v) -> Vctr v +| Rctr: Data (vtype v) -> Vctr v +| Fctr: Vctr v +| Nctr: Vctr v. + +Definition isCmp v (c1 c2: Vctr v): Prop := + match c1,c2 with + Wctr _, Nctr => True + | Rctr _, Rctr _ => True + | Rctr _, Nctr => True + | Rctr _, Fctr => True + | Nctr, _ => True + | _,_ => False + end. + +Lemma isCmp_dec: forall v (c1 c2: Vctr v), is_dec (isCmp v c1 c2). +intros. +induction c1; induction c2; simpl; intros; try (left; tauto); try (right; tauto). +Qed. + +Definition Vprod v (c1 c2: Vctr v): (isCmp v c1 c2) -> Vctr v := + match c1,c2 return isCmp v c1 c2 -> Vctr v with + | Wctr d, Nctr => fun h => Wctr v d + | Rctr d1, Rctr d2 => fun h => if Deq (vtype v) d1 d2 then Rctr v d1 else Fctr v + | Rctr d1, Nctr => fun h => Rctr v d1 + | Rctr d1, Fctr => fun h => Fctr v + | Fctr, Rctr _ => fun h => Fctr v + | Fctr, Fctr => fun h => Fctr v + | Fctr, Nctr => fun h => Fctr v + | Nctr, c2 => fun h => c2 + | _,_ => fun h => match h with end + end. + +Inductive MLabElem: Type := + Mctr: (forall v, Vctr v) -> MLabElem +| Merr: MLabElem. + +Definition MProd (m1 m2: MLabElem): MLabElem := + match m1,m2 with + Mctr c1, Mctr c2 => match allv (fun v => isCmp v (c1 v) (c2 v)) (fun v => isCmp_dec v (c1 v) (c2 v)) with + left h => Mctr (fun v => Vprod v (c1 v) (c2 v) (h v)) + | _ => Merr + end + | _,_ => Merr + end. + +Definition MLabel: Label := {| + LabElem := MLabElem; + LabProd m1 m2 := Some (MProd m1 m2); + LabBot m := exists c, m = Mctr c /\ exists v, c v = Fctr v; + LabError m := m = Merr +|}. + +Parameter Chan: Type. +Parameter ch_eq: eq_dec Chan. + +Definition CLabel(S: Chan->bool): Label := {| + LabElem := Chan; + LabProd := fun c1 c2 => if ch_eq c1 c2 then if S c1 then Some c1 else None else None; + LabBot := fun _ => False; + LabError := fun _ => False +|}. + +Definition FLabel(S: Chan->bool): Label := + TLabel (CLabel S ^* MLabel ^* MLabel ^* MLabel). + +Definition FTS := LTS (LabElem (FLabel (fun _ => true))). +Check (fun S (T1 T2: FTS) => Produit (FLabel S) T1 T2). +(* +Definition PAR (S: Chan -> bool) (T1 T2: FTS): FTS. +unfold FTS in *; simpl in *. +apply (Produit (FLabel S)). +apply T1. +apply T2. +Defined. + +Definition PAR (S: Chan -> bool) (T1 T2: FTS): FTS := + Produit (FLabel S) T1 T2. +*) +Lemma FTSirrel (S: Chan -> bool): FTS = LTS (LabElem (FLabel S)). +Proof. + unfold FTS. + simpl. + reflexivity. +Qed. + +Definition PAR (S: Chan -> bool) (T1 T2: FTS): FTS. +revert T2; revert T1. +rewrite (FTSirrel S). +apply (Produit (FLabel S)). +Defined. + +Record HTTS: Type := mkHTTS { + +}. diff --git a/test-suite/bugs/opened/2652a.v-disabled b/test-suite/bugs/opened/2652a.v-disabled new file mode 100644 index 00000000..0274037b --- /dev/null +++ b/test-suite/bugs/opened/2652a.v-disabled @@ -0,0 +1,106 @@ +Require Import Strings.String. +Require Import Classes.EquivDec. +Require Import Lists.List. + +Inductive Owner : Type := + | server : Owner + | client : Owner. + +Inductive ClassName : Type := + | className : string -> ClassName. + +Inductive Label : Type := + | label : nat -> Owner -> Label. + +Inductive Var : Type := + | var : string -> Var. + +Inductive FieldName : Type := + | fieldName : string -> Owner -> FieldName. + +Inductive MethodCall : Type := + | methodCall : string -> MethodCall. + +Inductive Exp : Type := + | varExp : Var -> Exp + | fieldReference : Var -> FieldName -> Exp + | methodCallExp : Var -> MethodCall -> list Var -> Exp + | allocation : ClassName -> list Var -> Exp + | cast : ClassName -> Var -> Exp. + +Inductive Stmt : Type := + | assignment : Var -> Exp -> Label -> Stmt + | returnStmt : Var -> Label -> Stmt + | fieldUpdate : Var -> FieldName -> Exp -> Label -> Stmt. + +Inductive Konst : Type := + | konst : ClassName -> (list (ClassName * FieldName)) -> list FieldName -> (list FieldName * FieldName) -> Konst. + +Inductive Method : Type := + | method : ClassName -> MethodCall -> list (ClassName * Var) -> list (ClassName * Var) -> (list Stmt) -> Method. + +Inductive Class : Type := + | class : ClassName -> ClassName -> (list (ClassName * FieldName)) -> (Konst * (list Method)) -> Class. + +Inductive Context : Type := + | context : nat -> Context. + +Inductive HContext : Type := + | heapContext : nat -> HContext. + +Inductive Location := loc : nat -> Location. + +Definition AbsLocation := ((Var * Context) + (FieldName * HContext)) % type. + +Definition CallStack := list (Stmt * Context * Var) % type. + +Inductive TypeState : Type := + | fresh : TypeState + | stale : TypeState. + +Definition Obj := (HContext * (FieldName -> option AbsLocation) * TypeState) % type. + +Definition Store := Location -> option Obj. + +Definition OwnerStore := Owner -> Store. + +Definition AbsStore := AbsLocation -> option (list Obj). + +Definition Stack := list (Var -> option Location). + +Definition Batch := list Location. + +Definition Sigma := (Stmt * Stack * OwnerStore * AbsStore * CallStack * Context * Batch) % type. + +Definition update {A : Type} {B : Type} `{EqDec A} `{EqDec B} (f : A -> B) (k : A) (v : B) : (A -> B) := + fun k' => if equiv_decb k' k then v else f k'. + + +Definition transfer : Label -> OwnerStore -> Batch -> (OwnerStore * Batch) := + fun _ o b => (o,b). + +Parameter succ : Label -> Stmt. + +Parameter owner : Label -> Owner. + +Inductive concreteSingleStep : Sigma -> Sigma -> Prop := + | fieldAssignmentLocal : forall v f_do f o so sigma_so hc m sigma'_so v' l st sigma absSigma cst c b sigma' sigma'' b', + (f_do = fieldName f o) -> so = owner(l) -> sigma_so = sigma(so) -> Some (hc, m, fresh) = sigma_so(st(v)) -> sigma'_so = update sigma_so st(v) (Some (hc, update m f_do st(v'), fresh)) + -> sigma' = update sigma so sigma'_so -> o = so -> (sigma'', b') = transfer l sigma' b -> + concreteSingleStep ((fieldUpdate v f_do (varExp v') l), st, sigma, absSigma, cst, c, b) + (succ(l), st, sigma'', absSigma, cst, c, b'). + + | fieldAssignmentRemote : forall v f_do f o so sigma_so hc m sigma'_so v' l st sigma absSigma cst c b sigma' sigma'' b', + (f_do = fieldName f o) -> so = owner(l) -> sigma_so = sigma(so) -> (hc, m, fresh) = sigma_so(st(v)) -> sigma'_so = update sigma_so st(v) (hc, update m f_do st(v'), fresh) + -> sigma' = update sigma so sigma'_so -> o <> so -> (sigma'', b') = transfer l sigma' (b ++ st(v)) -> + concreteSingleStep ((fieldUpdate v f_o (varExp v') l), st, sigma, absSigma, cst, c, b) + (succ(l), st, sigma'', absSigma, cst, c, b'') + | variableStep : forall v v' l st st' sigma sigma' absSigma cst c b b', + (st' = st ++ (update (fun _ => None) v st(v'))) -> (sigma',b') = transfer l sigma b -> + concreteSingleStep ((assignment v (varExp v') l), st, sigma, absSigma, cst, c, b) (succ(l), st', sigma', absSigma, cst, c, b') + | returnStep : forall v l st sigma absSigma cst c b v_ret s st' sigma' c' b', + (s,c',v_ret) = car(cst) -> st' = cdr(st) ++ update (fun _ => None) v_ret st(v) -> (sigma', b') = transfer l sigma b -> + concreteSingleStep ((returnStmt v l), st, sigma, absSigma, cst, c, b) (s, st', sigma', absSigma, cdr(cst), c', b') + | fieldReferenceStep : forall v v' f_do l st sigma absSigma cst c b so hc m' m st' sigma' absSigma cst c b', + so = owner(l) -> (hc, m', fresh) = sigma(so)(st(v')) -> m' = update m f_do l -> st' = st ++ update (fun _ => None) v l -> (sigma', b') = transfer l sigma b -> + concreteSingleStep ((assignment v (fieldReference v' f_do) l), st, sigma, absSigma, cst, c, b) (s, st', sigma', absSigma, cst, c, b'). diff --git a/test-suite/bugs/opened/2652b.v-disabled b/test-suite/bugs/opened/2652b.v-disabled new file mode 100644 index 00000000..b340436d --- /dev/null +++ b/test-suite/bugs/opened/2652b.v-disabled @@ -0,0 +1,88 @@ +(* This used to show a bug in evarutil. which is fixed in 8.4 *) +Require Import Strings.String. +Require Import Classes.EquivDec. +Require Import Lists.List. + +Inductive Owner : Type := + | server : Owner + | client : Owner. + +Inductive ClassName : Type := + | className : string -> ClassName. + +Inductive Label : Type := + | label : nat -> Owner -> Label. + +Inductive Var : Type := + | var : string -> Var. + +Inductive FieldName : Type := + | fieldName : string -> Owner -> FieldName. + +Inductive MethodCall : Type := + | methodCall : string -> MethodCall. + +Inductive Exp : Type := + | varExp : Var -> Exp + | fieldReference : Var -> FieldName -> Exp + | methodCallExp : Var -> MethodCall -> list Var -> Exp + | allocation : ClassName -> list Var -> Exp + | cast : ClassName -> Var -> Exp. + +Inductive Stmt : Type := + | assignment : Var -> Exp -> Label -> Stmt + | returnStmt : Var -> Label -> Stmt + | fieldUpdate : Var -> FieldName -> Exp -> Label -> Stmt. + +Inductive Konst : Type := + | konst : ClassName -> (list (ClassName * FieldName)) -> list FieldName -> (list FieldName * FieldName) -> Konst. + +Inductive Method : Type := + | method : ClassName -> MethodCall -> list (ClassName * Var) -> list (ClassName * Var) -> (list Stmt) -> Method. + +Inductive Class : Type := + | class : ClassName -> ClassName -> (list (ClassName * FieldName)) -> (Konst * (list Method)) -> Class. + +Inductive Context : Type := + | context : nat -> Context. + +Inductive HContext : Type := + | heapContext : nat -> HContext. + +Inductive Location := loc : nat -> Location. + +Definition AbsLocation := ((Var * Context) + (FieldName * HContext)) % type. + +Definition CallStack := list (Stmt * Context * Var) % type. + +Inductive TypeState : Type := + | fresh : TypeState + | stale : TypeState. + +Definition Obj := (HContext * (FieldName -> option AbsLocation) * TypeState) % type. + +Definition Store := Location -> option Obj. + +Definition OwnerStore := Owner -> Store. + +Definition AbsStore := AbsLocation -> option (list Obj). + +Definition Stack := list (Var -> option Location). + +Definition Batch := list Location. + +Definition Sigma := (Stmt * Stack * OwnerStore * AbsStore * CallStack * Context * Batch) % type. + +Definition update {A : Type} {B : Type} `{EqDec A} `{EqDec B} (f : A -> B) (k : A) (v : B) : (A -> B) := + fun k' => if equiv_decb k' k then v else f k'. + +Parameter succ : Label -> Stmt. + +Inductive concreteSingleStep : Sigma -> Sigma -> Prop := + | fieldAssignmentLocal : forall v f_do f o so sigma_so hc m sigma'_so v' l st sigma absSigma cst c b sigma' sigma'' b', + Some (hc, m, fresh) = sigma_so(st(v)) -> sigma'_so = update sigma_so st(v) (Some (hc, update m f_do st(v'), fresh)) + -> + concreteSingleStep ((fieldUpdate v f_do (varExp v') l), st, sigma, absSigma, cst, c, b) + (succ(l), st, sigma'', absSigma, cst, c, b'). + +. diff --git a/test-suite/bugs/opened/2800.v b/test-suite/bugs/opened/2800.v new file mode 100644 index 00000000..c559ab0c --- /dev/null +++ b/test-suite/bugs/opened/2800.v @@ -0,0 +1,6 @@ +Goal False. + +Fail intuition + match goal with + | |- _ => idtac " foo" + end. diff --git a/test-suite/bugs/opened/2814.v b/test-suite/bugs/opened/2814.v new file mode 100644 index 00000000..a740b438 --- /dev/null +++ b/test-suite/bugs/opened/2814.v @@ -0,0 +1,5 @@ +Require Import Program. + +Goal forall (x : Type) (f g : Type -> Type) (H : f x ~= g x), False. + intros. + Fail induction H. diff --git a/test-suite/bugs/opened/2951.v b/test-suite/bugs/opened/2951.v new file mode 100644 index 00000000..3739247b --- /dev/null +++ b/test-suite/bugs/opened/2951.v @@ -0,0 +1 @@ +Class C (A: Type) : Type := { f: A }. diff --git a/test-suite/bugs/opened/3010.v-disabled b/test-suite/bugs/opened/3010.v-disabled new file mode 100644 index 00000000..f2906bd6 --- /dev/null +++ b/test-suite/bugs/opened/3010.v-disabled @@ -0,0 +1 @@ +Definition em {A R} (k : forall s : sum A _, match s with inl x => R x | inr y => R end) := k (inr (fun x => k (inl x))). \ No newline at end of file diff --git a/test-suite/bugs/opened/3045.v b/test-suite/bugs/opened/3045.v new file mode 100644 index 00000000..b7f40b4a --- /dev/null +++ b/test-suite/bugs/opened/3045.v @@ -0,0 +1,30 @@ +Set Asymmetric Patterns. +Generalizable All Variables. +Set Implicit Arguments. +Set Universe Polymorphism. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Arguments Compose {obj} [C s d d'] m1 m2 : rename. + +Inductive ReifiedMorphism : forall objC (C : SpecializedCategory objC), C -> C -> Type := +| ReifiedComposedMorphism : forall objC C s d d', ReifiedMorphism C d d' -> ReifiedMorphism C s d -> @ReifiedMorphism objC C s d'. + +Fixpoint ReifiedMorphismDenote objC C s d (m : @ReifiedMorphism objC C s d) : Morphism C s d := + match m in @ReifiedMorphism objC C s d return Morphism C s d with + | ReifiedComposedMorphism _ _ _ _ _ m1 m2 => Compose (@ReifiedMorphismDenote _ _ _ _ m1) + (@ReifiedMorphismDenote _ _ _ _ m2) + end. + +Fixpoint ReifiedMorphismSimplifyWithProof objC C s d (m : @ReifiedMorphism objC C s d) +: { m' : ReifiedMorphism C s d | ReifiedMorphismDenote m = ReifiedMorphismDenote m' }. +refine match m with + | ReifiedComposedMorphism _ _ s0 d0 d0' m1 m2 => _ + end; clear m. +Fail destruct (@ReifiedMorphismSimplifyWithProof _ _ _ _ m1) as [ [] ? ]. diff --git a/test-suite/bugs/opened/3071.v b/test-suite/bugs/opened/3071.v new file mode 100644 index 00000000..611ac606 --- /dev/null +++ b/test-suite/bugs/opened/3071.v @@ -0,0 +1,5 @@ +Definition foo := True. + +Section foo. + Global Arguments foo / . +Fail End foo. diff --git a/test-suite/bugs/opened/3092.v b/test-suite/bugs/opened/3092.v new file mode 100644 index 00000000..9db21d15 --- /dev/null +++ b/test-suite/bugs/opened/3092.v @@ -0,0 +1,9 @@ +Fail Fixpoint le_pred (n1 n2 : nat) (H1 : n1 <= n2) : pred n1 <= pred n2 := + match H1 with + | le_n => le_n (pred _) + | le_S _ H2 => + match n2 with + | 0 => fun H3 => H3 + | S _ => le_S _ _ + end (le_pred _ _ H2) + end. diff --git a/test-suite/bugs/opened/3100.v b/test-suite/bugs/opened/3100.v new file mode 100644 index 00000000..6f35a74d --- /dev/null +++ b/test-suite/bugs/opened/3100.v @@ -0,0 +1,9 @@ +Fixpoint F (n : nat) (A : Type) : Type := + match n with + | 0 => True + | S n => forall (x : A), F n (x = x) + end. + +Goal forall A n, (forall (x : A) (e : x = x), F n (e = e)). +intros A n. +Fail change (forall x, F n (x = x)) with (F (S n)). diff --git a/test-suite/bugs/opened/3166.v b/test-suite/bugs/opened/3166.v new file mode 100644 index 00000000..e1c29a95 --- /dev/null +++ b/test-suite/bugs/opened/3166.v @@ -0,0 +1,83 @@ +Set Asymmetric Patterns. + +Section eq. + Let A := { X : Type & X }. + Let B := (fun x : A => projT1 x). + Let T := (fun (a' : A) (b' : B a') => projT2 a' = b'). + Let T' := T. + Let t1T := (fun _ : A => unit). + Let f1 := (fun x (_ : t1T x) => projT2 x). + Let t1 := (fun x (y : t1T x) => @eq_refl (projT1 x) (projT2 x)). + Let t1T' := t1T. + Let f1' := f1. + Let t1' := t1. + + Theorem eq_matches_commute + a' b' (t' : T a' b') + (rta : forall b'', T' a' b'' -> A) + (rtb : forall b'' t'', B (rta b'' t'')) + (rt1 : forall y, T _ (rtb (f1' a' y) (@t1' a' y))) + (R : forall (b : B (rta b' t')), T _ b -> Type) + (r1 : forall y, R (f1 _ y) (@t1 _ y)) + : match + match t' as t0' in (@eq _ _ b0') return T (rta b0' t0') (rtb b0' t0') with + | eq_refl => rt1 tt + end + as t0 in (@eq _ _ b0) + return R b0 t0 + with + | eq_refl => r1 tt + end + = + match t' + as t0' in (@eq _ _ b0') + return (forall (R : forall (b : B (rta b0' t0')), T _ b -> Type) + (r1 : forall y, R (f1 _ y) (@t1 _ y)), + R _ (match t0' as t0'0 in (@eq _ _ b0'0) return T (rta b0'0 t0'0) (rtb b0'0 t0'0) with + | eq_refl => rt1 tt + end)) + with + | eq_refl => fun _ r1 => + match rt1 tt with + | eq_refl => r1 tt + end + end R r1. + Proof. + destruct t'; reflexivity. + Defined. + + Theorem eq_match_beta2 + a b (t : T a b) + X + (R : forall b' (t' : T a b'), X b' -> Type) + (r1 : forall y x, R _ (@t1 _ y) x) + x + : match t as t' in (@eq _ _ b') return forall x, R b' t' x with + | eq_refl => r1 tt + end (x b) + = + match t as t' in (@eq _ _ b') return R b' t' (x b') with + | eq_refl => r1 tt (x _) + end. + Proof. + destruct t; reflexivity. + Defined. +End eq. + +Definition typeof {T} (_ : T) := T. + +Eval compute in (eq_sym (eq_sym _)). +Goal forall T (x y : T) (p : x = y), True. + intros. + pose proof + (@eq_matches_commute + (existT (fun T => T) T x) y p + (fun b'' _ => existT (fun T => T) T b'') + (fun _ _ => x) + (fun _ => eq_refl) + (fun x' _ => x' = y) + (fun _ => eq_refl) + ) as H0. + compute in H0. + change (fun (x' : T) (_ : y = x') => x' = y) with ((fun y => fun (x' : T) (_ : y = x') => x' = y) y) in H0. + Fail pose proof (fun k => @eq_trans _ _ _ k H0). diff --git a/test-suite/bugs/opened/3186.v-disabled b/test-suite/bugs/opened/3186.v-disabled new file mode 100644 index 00000000..d0bcb920 --- /dev/null +++ b/test-suite/bugs/opened/3186.v-disabled @@ -0,0 +1,4 @@ +Fixpoint a (_:unit):= +match eq_refl with +|eq_refl => a +end. \ No newline at end of file diff --git a/test-suite/bugs/opened/3209.v b/test-suite/bugs/opened/3209.v new file mode 100644 index 00000000..3203afa1 --- /dev/null +++ b/test-suite/bugs/opened/3209.v @@ -0,0 +1,17 @@ +Inductive eqT {A} (x : A) : A -> Type := + reflT : eqT x x. +Definition Bi_inv (A B : Type) (f : (A -> B)) := + sigT (fun (g : B -> A) => + sigT (fun (h : B -> A) => + sigT (fun (α : forall b : B, eqT (f (g b)) b) => + forall a : A, eqT (h (f a)) a))). +Definition TEquiv (A B : Type) := sigT (fun (f : A -> B) => Bi_inv _ _ f). + +Axiom UA : forall (A B : Type), TEquiv (TEquiv A B) (eqT A B). +Definition idtoeqv {A B} (e : eqT A B) : TEquiv A B := + sigT_rect (fun _ => TEquiv A B) + (fun (f : TEquiv A B -> eqT A B) H => + sigT_rect (fun _ => TEquiv A B) + (fun g _ => g e) + H) + (UA A B). diff --git a/test-suite/bugs/opened/3230.v b/test-suite/bugs/opened/3230.v new file mode 100644 index 00000000..265310b1 --- /dev/null +++ b/test-suite/bugs/opened/3230.v @@ -0,0 +1,14 @@ +Structure type : Type := Pack { ob : Type }. +Polymorphic Record category := { foo : Type }. +Definition FuncComp := Pack category. +Axiom C : category. + +Check (C : ob FuncComp). (* OK *) + +Canonical Structure FuncComp. + +Check (C : ob FuncComp). +(* Toplevel input, characters 15-39: +Error: +The term "C" has type "category" while it is expected to have type + "ob FuncComp". *) diff --git a/test-suite/bugs/opened/3248.v b/test-suite/bugs/opened/3248.v new file mode 100644 index 00000000..9e7d1eb5 --- /dev/null +++ b/test-suite/bugs/opened/3248.v @@ -0,0 +1,17 @@ +Ltac ret_and_left f := + let tac := ret_and_left in + let T := type of f in + lazymatch eval hnf in T with + | ?T' -> _ => + let ret := constr:(fun x' : T' => $(tac (f x'))$) in + exact ret + | ?T' => exact f + end. + +Goal forall A B : Prop, forall x y : A, True. +Proof. + intros A B x y. + pose (f := fun (x y : A) => conj x y). + pose (a := $(ret_and_left f)$). + Fail unify (a x y) (conj x y). +Abort. diff --git a/test-suite/bugs/opened/3263.v b/test-suite/bugs/opened/3263.v new file mode 100644 index 00000000..6de13f74 --- /dev/null +++ b/test-suite/bugs/opened/3263.v @@ -0,0 +1,231 @@ +(* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines, 2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *) +Generalizable All Variables. +Set Implicit Arguments. + +Arguments fst {_ _} _. +Arguments snd {_ _} _. + +Axiom cheat : forall {T}, T. + +Reserved Notation "g 'o' f" (at level 40, left associativity). + +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (paths x y) : type_scope. + +Definition symmetry {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory (object : Type) := + Build_PreCategory' { + object :> Type := object; + morphism : object -> object -> Type; + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1); + associativity_sym : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + m3 o (m2 o m1) = (m3 o m2) o m1; + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f; + identity_identity : forall x, identity x o identity x = identity x + }. +Bind Scope category_scope with PreCategory. +Arguments PreCategory {_}. +Arguments identity {_} [!C%category] x%object : rename. + +Arguments compose {_} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + +Infix "o" := compose : morphism_scope. + +Delimit Scope functor_scope with functor. +Local Open Scope morphism_scope. +Record Functor `(C : @PreCategory objC, D : @PreCategory objD) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + composition_of : forall s d d' + (m1 : morphism C s d) (m2: morphism C d d'), + morphism_of _ _ (m2 o m1) + = (morphism_of _ _ m2) o (morphism_of _ _ m1); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) + }. +Bind Scope functor_scope with Functor. + +Arguments morphism_of {_} [C%category] {_} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. + +Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. + +Class IsIsomorphism `{C : @PreCategory objC} {s d} (m : morphism C s d) := + { + morphism_inverse : morphism C d s; + left_inverse : morphism_inverse o m = identity _; + right_inverse : m o morphism_inverse = identity _ + }. + +Definition opposite `(C : @PreCategory objC) : PreCategory + := @Build_PreCategory' + C + (fun s d => morphism C d s) + (identity (C := C)) + (fun _ _ _ m1 m2 => m2 o m1) + (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _ _) + (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _ _) + (fun _ _ => @right_identity _ _ _ _) + (fun _ _ => @left_identity _ _ _ _) + (@identity_identity _ C). + +Notation "C ^op" := (opposite C) (at level 3) : category_scope. + +Definition prod `(C : @PreCategory objC, D : @PreCategory objD) : @PreCategory (objC * objD). + refine (@Build_PreCategory' + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) + * morphism D (snd s) (snd d))%type) + (fun x => (identity (fst x), identity (snd x))) + (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1)) + _ + _ + _ + _ + _); admit. +Defined. +Infix "*" := prod : category_scope. + +Definition compose_functor `(C : @PreCategory objC, D : @PreCategory objD, E : @PreCategory objE) (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => morphism_of G (morphism_of F m)) + cheat + cheat. + +Infix "o" := compose_functor : functor_scope. + +Record NaturalTransformation `(C : @PreCategory objC, D : @PreCategory objD) (F G : Functor C D) := + Build_NaturalTransformation' { + components_of :> forall c, morphism D (F c) (G c); + commutes : forall s d (m : morphism C s d), + components_of d o F _1 m = G _1 m o components_of s; + + commutes_sym : forall s d (m : C.(morphism) s d), + G _1 m o components_of s = components_of d o F _1 m + }. +Definition functor_category `(C : @PreCategory objC, D : @PreCategory objD) : PreCategory + := @Build_PreCategory' (Functor C D) + (@NaturalTransformation _ C _ D) + cheat + cheat + cheat + cheat + cheat + cheat + cheat. + +Definition opposite_functor `(F : @Functor objC C objD D) : Functor C^op D^op + := Build_Functor (C^op) (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). + +Definition opposite_invL `(F : @Functor objC C^op objD D) : Functor C D^op + := Build_Functor C (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). +Notation "F ^op" := (opposite_functor F) : functor_scope. + +Notation "F ^op'L" := (opposite_invL F) (at level 3) : functor_scope. +Definition fst `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) C + := Build_Functor (C * D) C + (@fst _ _) + (fun _ _ => @fst _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). + +Definition snd `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) D + := Build_Functor (C * D) D + (@snd _ _) + (fun _ _ => @snd _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). +Definition prod_functor `(F : @Functor objC C objD D, F' : @Functor objC C objD' D') +: Functor C (D * D') + := Build_Functor + C (D * D') + (fun c => (F c, F' c)) + (fun s d m => (F _1 m, F' _1 m))%morphism + cheat + cheat. +Definition pair `(F : @Functor objC C objD D, F' : @Functor objC' C' objD' D') : Functor (C * C') (D * D') + := (prod_functor (F o fst) (F' o snd))%functor. +Notation cat_of obj := + (@Build_PreCategory' obj + (fun x y => forall _ : x, y) + (fun _ x => x) + (fun _ _ _ f g x => f (g x))%core + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ => idpath)). + +Definition hom_functor `(C : @PreCategory objC) : Functor (C^op * C) (cat_of Type) + := Build_Functor _ _ cheat cheat cheat cheat. + +Definition induced_hom_natural_transformation `(F : @Functor objC C objD D) +: NaturalTransformation (hom_functor C) (hom_functor D o pair F^op F) + := Build_NaturalTransformation' _ _ cheat cheat cheat. + +Class IsFullyFaithful `(F : @Functor objC C objD D) + := is_fully_faithful + : forall x y : C, + IsIsomorphism (induced_hom_natural_transformation F (x, y)). + +Definition coyoneda `(A : @PreCategory objA) : Functor A^op (@functor_category _ A _ (cat_of Type)) + := cheat. + +Definition yoneda `(A : @PreCategory objA) : Functor A (@functor_category _ A^op _ (cat_of Type)) + := (((coyoneda A^op)^op'L)^op'L)%functor. +Definition coyoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@coyoneda _ A). +Admitted. + +Definition yoneda_embedding_fast `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). +Proof. + intros a b. + pose proof (coyoneda_embedding A^op a b) as CYE. + unfold yoneda. + Time let t := (type of CYE) in + let t' := (eval simpl in t) in pose proof ((fun (x : t) => (x : t')) CYE) as CYE'. (* Finished transaction in 0. secs (0.216013u,0.004s) *) + Fail Timeout 1 let t := match goal with |- ?G => constr:(G) end in + let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). + Time let t := match goal with |- ?G => constr:(G) end in + let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). (* Finished transaction in 0. secs (0.248016u,0.s) *) +Fail Timeout 2 Defined. +Time Defined. (* Finished transaction in 1. secs (0.432027u,0.s) *) + +Definition yoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). +Proof. + intros a b. + pose proof (coyoneda_embedding A^op a b) as CYE. + unfold yoneda; simpl in *. + Fail Timeout 1 exact CYE. + Time exact CYE. (* Finished transaction in 0. secs (0.012001u,0.s) *) +Fail Timeout 60 Defined. (* Timeout! *) diff --git a/test-suite/bugs/opened/3277.v b/test-suite/bugs/opened/3277.v new file mode 100644 index 00000000..19ed787d --- /dev/null +++ b/test-suite/bugs/opened/3277.v @@ -0,0 +1,7 @@ +Tactic Notation "evarr" open_constr(x) := let y := constr:(x) in exact y. + +Goal True. + evarr _. +Admitted. +Goal True. + Fail exact $(evarr _)$. (* Error: Cannot infer this placeholder. *) diff --git a/test-suite/bugs/opened/3278.v b/test-suite/bugs/opened/3278.v new file mode 100644 index 00000000..ced535af --- /dev/null +++ b/test-suite/bugs/opened/3278.v @@ -0,0 +1,25 @@ +Module a. + Check let x' := _ in + $(exact x')$. + + Notation foo x := (let x' := x in $(exact x')$). + + Fail Check foo _. (* Error: +Cannot infer an internal placeholder of type "Type" in environment: + +x' := ?42 : ?41 +. *) +End a. + +Module b. + Notation foo x := (let x' := x in let y := ($(exact I)$ : True) in I). + Notation bar x := (let x' := x in let y := (I : True) in I). + + Check let x' := _ in $(exact I)$. (* let x' := ?5 in I *) + Check bar _. (* let x' := ?9 in let y := I in I *) + Fail Check foo _. (* Error: +Cannot infer an internal placeholder of type "Type" in environment: + +x' := ?42 : ?41 +. *) +End b. diff --git a/test-suite/bugs/opened/3283.v b/test-suite/bugs/opened/3283.v new file mode 100644 index 00000000..3ab5416e --- /dev/null +++ b/test-suite/bugs/opened/3283.v @@ -0,0 +1,28 @@ +Notation "P |-- Q" := (@eq nat P Q) (at level 80, Q at level 41, no associativity) . +Notation "x &&& y" := (plus x y) (at level 40, left associativity, y at next level) . +Notation "'Ex' x , P " := (plus x P) (at level 65, x at level 99, P at level 80). + +(* Succeed *) +Check _ |-- _ &&& _ -> _. +Check _ |-- _ &&& (Ex _, _ ) -> _. +Check _ |-- (_ &&& Ex _, _ ) -> _. + +(* Why does this fail? *) +Fail Check _ |-- _ &&& Ex _, _ -> _. +(* The command has indeed failed with message: +=> Error: The term "Ex ?17, ?18" has type "nat" +which should be Set, Prop or Type. *) + +(* Just in case something is strange with -> *) +Notation "P ----> Q" := (P -> Q) (right associativity, at level 99, Q at next level). + +(* Succeed *) +Check _ |-- _ &&& _ ----> _. +Check _ |-- _ &&& (Ex _, _ ) ----> _. +Check _ |-- (_ &&& Ex _, _ ) ----> _. + +(* Why does this fail? *) +Fail Check _ |-- _ &&& Ex _, _ ----> _. +(* The command has indeed failed with message: +=> Error: The term "Ex ?31, ?32" has type "nat" +which should be Set, Prop or Type.*) diff --git a/test-suite/bugs/opened/3295.v b/test-suite/bugs/opened/3295.v new file mode 100644 index 00000000..2a156e33 --- /dev/null +++ b/test-suite/bugs/opened/3295.v @@ -0,0 +1,104 @@ +Require Export Morphisms Setoid. + +Class lops := lmk_ops { + car: Type; + weq: relation car +}. + +Implicit Arguments car []. + +Coercion car: lops >-> Sortclass. + +Instance weq_Equivalence `{lops}: Equivalence weq. +Proof. +Admitted. + +Module lset. +Canonical Structure lset_ops A := lmk_ops (list A) (fun h k => True). +End lset. + +Class ops := mk_ops { + ob: Type; + mor: ob -> ob -> lops; + dot: forall n m p, mor n m -> mor m p -> mor n p +}. +Coercion mor: ops >-> Funclass. +Implicit Arguments ob []. + +Instance dot_weq `{ops} n m p: Proper (weq ==> weq ==> weq) (dot n m p). +Proof. +Admitted. + +Section s. + +Import lset. + +Context `{X:lops} {I: Type}. + +Axiom sup : forall (f: I -> X) (J : list I), X. + +Global Instance sup_weq: Proper (pointwise_relation _ weq ==> weq ==> weq) sup. +Proof. +Admitted. + +End s. + +Axiom ord : forall (n : nat), Type. +Axiom seq : forall n, list (ord n). + +Infix "==" := weq (at level 79). +Infix "*" := (dot _ _ _) (left associativity, at level 40). + +Notation "∑_ ( i ∈ l ) f" := (@sup (mor _ _) _ (fun i => f) l) + (at level 41, f at level 41, i, l at level 50). + +Axiom dotxsum : forall `{X : ops} I J n m p (f: I -> X m n) (x: X p m) y, + x * (∑_(i∈ J) f i) == y. + +Definition mx X n m := ord n -> ord m -> X. + +Section bsl. +Context `{X : ops} {u: ob X}. +Notation U := (car (@mor X u u)). + +Lemma toto n m p q (M : mx U n m) N (P : mx U p q) Q i j : ∑_(j0 ∈ seq m) M i j0 * (∑_(j1 ∈ seq p) N j0 j1 * P j1 j) == Q. +Proof. + Fail setoid_rewrite dotxsum. + (* Toplevel input, characters 0-22: +Error: +Tactic failure:setoid rewrite failed: Unable to satisfy the rewriting constraints. +Unable to satisfy the following constraints: +UNDEFINED EVARS: + ?101==[X u n m p q M N P Q i j j0 |- U] (goal evar) + ?106==[X u n m p q M N P Q i j |- relation (X u u)] (internal placeholder) + ?107==[X u n m p q M N P Q i j |- relation (list (ord m))] + (internal placeholder) + ?108==[X u n m p q M N P Q i j (do_subrelation:=do_subrelation) + |- Proper (pointwise_relation (ord m) weq ==> ?107 ==> ?106) sup] + (internal placeholder) + ?109==[X u n m p q M N P Q i j |- ProperProxy ?107 (seq m)] + (internal placeholder) + ?110==[X u n m p q M N P Q i j |- relation (X u u)] (internal placeholder) + ?111==[X u n m p q M N P Q i j (do_subrelation:=do_subrelation) + |- Proper (?106 ==> ?110 ==> Basics.flip Basics.impl) weq] + (internal placeholder) + ?112==[X u n m p q M N P Q i j |- ProperProxy ?110 Q] (internal placeholder)UNIVERSES: + {} |= Top.14 <= Top.37 + Top.25 <= Top.24 + Top.25 <= Top.32 + +ALGEBRAIC UNIVERSES:{} +UNDEFINED UNIVERSES:METAS: + 470[y] := ?101 : car (?99 ?467 ?465) + 469[x] := M i _UNBOUND_REL_1 : car (?99 ?467 ?466) [type is checked] + 468[f] := fun i : ?463 => N _UNBOUND_REL_2 i * P i j : + ?463 -> ?99 ?466 ?465 [type is checked] + 467[p] := u : ob ?99 [type is checked] + 466[m] := u : ob ?99 [type is checked] + 465[n] := u : ob ?99 [type is checked] + 464[J] := seq p : list ?463 [type is checked] + 463[I] := ord p : Type [type is checked] + *) +Abort. + +End bsl. diff --git a/test-suite/bugs/opened/3298.v b/test-suite/bugs/opened/3298.v new file mode 100644 index 00000000..bce7c3f2 --- /dev/null +++ b/test-suite/bugs/opened/3298.v @@ -0,0 +1,23 @@ +Module JGross. + Hint Extern 1 => match goal with |- match ?E with end => case E end. + + Goal forall H : False, match H return Set with end. + Proof. + intros. + Fail solve [ eauto ]. (* No applicable tactic *) + admit. + Qed. +End JGross. + +Section BenDelaware. + Hint Extern 0 => admit. + Goal forall (H : False), id (match H return Set with end). + Proof. + eauto. + Qed. + Goal forall (H : False), match H return Set with end. + Proof. + Fail solve [ eauto ] . + admit. + Qed. +End BenDelaware. diff --git a/test-suite/bugs/opened/3304.v b/test-suite/bugs/opened/3304.v new file mode 100644 index 00000000..529cc737 --- /dev/null +++ b/test-suite/bugs/opened/3304.v @@ -0,0 +1,3 @@ +Fail Notation "( x , y , .. , z )" := $(let r := constr:(prod .. (prod x y) .. z) in r)$. +(* The command has indeed failed with message: +=> Error: Special token .. is for use in the Notation command. *) diff --git a/test-suite/bugs/opened/3311.v b/test-suite/bugs/opened/3311.v new file mode 100644 index 00000000..1c66bc1e --- /dev/null +++ b/test-suite/bugs/opened/3311.v @@ -0,0 +1,10 @@ +Require Import Setoid. +Axiom bar : True = False. +Goal True. + Fail setoid_rewrite bar. (* Toplevel input, characters 15-33: +Error: +Tactic failure:setoid rewrite failed: Unable to satisfy the rewriting constraints. + +Could not find an instance for "subrelation eq (Basics.flip Basics.impl)". +With the following constraints: +?3 : "True" *) diff --git a/test-suite/bugs/opened/3312.v b/test-suite/bugs/opened/3312.v new file mode 100644 index 00000000..749921e2 --- /dev/null +++ b/test-suite/bugs/opened/3312.v @@ -0,0 +1,5 @@ +Require Import Setoid. +Axiom bar : 0 = 1. +Goal 0 = 1. + Fail rewrite_strat bar. (* Toplevel input, characters 15-32: +Error: Tactic failure:setoid rewrite failed: Nothing to rewrite. *) diff --git a/test-suite/bugs/opened/3320.v b/test-suite/bugs/opened/3320.v new file mode 100644 index 00000000..05cf7328 --- /dev/null +++ b/test-suite/bugs/opened/3320.v @@ -0,0 +1,4 @@ +Goal forall x : nat, True. + fix 1. + assumption. +Fail Qed. diff --git a/test-suite/bugs/opened/3326.v b/test-suite/bugs/opened/3326.v new file mode 100644 index 00000000..f73117a2 --- /dev/null +++ b/test-suite/bugs/opened/3326.v @@ -0,0 +1,18 @@ +Class ORDER A := Order { + LEQ : A -> A -> bool; + leqRefl: forall x, true = LEQ x x +}. + +Section XXX. + +Variable A:Type. +Variable (O:ORDER A). +Definition aLeqRefl := @leqRefl _ O. + +Lemma OK : forall x, true = LEQ x x. + intros. + unfold LEQ. + destruct O. + clear. + Fail apply aLeqRefl. (* Toplevel input, characters 15-30: +Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/opened/3343.v b/test-suite/bugs/opened/3343.v new file mode 100644 index 00000000..6c5a85f9 --- /dev/null +++ b/test-suite/bugs/opened/3343.v @@ -0,0 +1,46 @@ +(* File reduced by coq-bug-finder from original input, then from 13699 lines to 656 lines, then from 584 lines to 200 lines *) +Set Asymmetric Patterns. +Require Export Coq.Lists.List. +Export List.ListNotations. + +Record CFGV := { Terminal : Type; VarSym : Type }. + +Section Gram. + Context {G : CFGV}. + + Inductive Pattern : (Terminal G) -> Type := + | ptleaf : forall (T : Terminal G), + nat -> Pattern T + with Mixture : list (Terminal G) -> Type := + | mtcons : forall {h: Terminal G} + {tl: list (Terminal G)}, + Pattern h -> Mixture tl -> Mixture (h::tl). + + Variable vc : VarSym G. + + Fixpoint pBVars {gs} (p : Pattern gs) : (list nat) := + match p with + | ptleaf _ _ => [] + end + with mBVars {lgs} (pts : Mixture lgs) : (list nat) := + match pts with + | mtcons _ _ _ tl => mBVars tl + end. + + Lemma mBndngVarsAsNth : + forall mp (m : @Mixture mp), + mBVars m = [2]. + Proof. + intros. + induction m. progress simpl. + Admitted. +End Gram. + +Lemma mBndngVarsAsNth' {G : CFGV} { vc : VarSym G} : + forall mp (m : @Mixture G mp), + mBVars m = [2]. +Proof. + intros. + induction m. + Fail progress simpl. + (* simpl did nothing here, while it does something inside the section; this is probably a bug*) diff --git a/test-suite/bugs/opened/3345.v b/test-suite/bugs/opened/3345.v new file mode 100644 index 00000000..b61174a8 --- /dev/null +++ b/test-suite/bugs/opened/3345.v @@ -0,0 +1,144 @@ +(* File reduced by coq-bug-finder from original input, then from 1972 lines to 136 lines, then from 119 lines to 105 lines *) +Global Set Implicit Arguments. +Require Import Coq.Lists.List Program. +Section IndexBound. + Context {A : Set}. + Class IndexBound (a : A) (Bound : list A) := + { ibound :> nat; + boundi : nth_error Bound ibound = Some a}. + Global Arguments ibound [a Bound] _ . + Global Arguments boundi [a Bound] _. + Record BoundedIndex (Bound : list A) := { bindex :> A; indexb :> IndexBound bindex Bound }. +End IndexBound. +Context {A : Type} {C : Set}. +Variable (projAC : A -> C). +Lemma None_neq_Some +: forall (AnyT AnyT' : Type) (a : AnyT), + None = Some a -> AnyT'. + admit. +Defined. +Program Definition nth_Bounded' + (Bound : list A) + (c : C) + (a_opt : option A) + (nth_n : option_map projAC a_opt = Some c) +: A := match a_opt as x + return (option_map projAC x = Some c) -> A with + | Some a => fun _ => a + | None => fun f : None = Some _ => ! + end nth_n. +Lemma nth_error_map : + forall n As c_opt, + nth_error (map projAC As) n = c_opt + -> option_map projAC (nth_error As n) = c_opt. + admit. +Defined. +Definition nth_Bounded + (Bound : list A) + (idx : BoundedIndex (map projAC Bound)) +: A := nth_Bounded' Bound (nth_error Bound (ibound idx)) + (nth_error_map _ _ (boundi idx)). +Program Definition nth_Bounded_ind2 + (P : forall As, BoundedIndex (map projAC As) + -> BoundedIndex (map projAC As) + -> A -> A -> Prop) +: forall (Bound : list A) + (idx : BoundedIndex (map projAC Bound)) + (idx' : BoundedIndex (map projAC Bound)), + match nth_error Bound (ibound idx), nth_error Bound (ibound idx') with + | Some a, Some a' => P Bound idx idx' a a' + | _, _ => True + end + -> P Bound idx idx' (nth_Bounded _ idx) (nth_Bounded _ idx'):= + fun Bound idx idx' => + match (nth_error Bound (ibound idx)) as e, (nth_error Bound (ibound idx')) as e' + return + (forall (f : option_map _ e = Some (bindex idx)) + (f' : option_map _ e' = Some (bindex idx')), + (match e, e' with + | Some a, Some a' => P Bound idx idx' a a' + | _, _ => True + end) + -> P Bound idx idx' + (match e as e'' return + option_map _ e'' = Some (bindex idx) + -> A + with + | Some a => fun _ => a + | _ => fun f => _ + end f) + (match e' as e'' return + option_map _ e'' = Some (bindex idx') + -> A + with + | Some a => fun _ => a + | _ => fun f => _ + end f')) with + | Some a, Some a' => fun _ _ H => _ + | _, _ => fun f => _ + end (nth_error_map _ _ (boundi idx)) + (nth_error_map _ _ (boundi idx')). + +Lemma nth_Bounded_eq +: forall (Bound : list A) + (idx idx' : BoundedIndex (map projAC Bound)), + ibound idx = ibound idx' + -> nth_Bounded Bound idx = nth_Bounded Bound idx'. +Proof. + intros. + eapply nth_Bounded_ind2 with (idx := idx) (idx' := idx'). + simpl. + (* The [case_eq] should not Fail. More importantly, [Fail case_eq ...] should succeed if [case_eq ...] fails. It doesn't!!! So I resort to [Fail Fail try (case_eq ...)]. *) + Fail Fail try (case_eq (nth_error Bound (ibound idx'))). +(* Toplevel input, characters 15-54: +In nested Ltac calls to "case_eq" and "pattern x at - 1", last call failed. +Error: The abstracted term +"fun e : Exc A => + forall e0 : nth_error Bound (ibound idx') = e, + match + nth_error Bound (ibound idx) as anonymous'0 + return (anonymous'0 = nth_error Bound (ibound idx) -> e = e -> Prop) + with + | Some a => + match + e as anonymous' + return + (Some a = nth_error Bound (ibound idx) -> anonymous' = e -> Prop) + with + | Some a' => + fun (_ : Some a = nth_error Bound (ibound idx)) (_ : Some a' = e) => + a = a' + | None => + fun (_ : Some a = nth_error Bound (ibound idx)) (_ : None = e) => + True + end + | None => fun (_ : None = nth_error Bound (ibound idx)) (_ : e = e) => True + end eq_refl e0" is not well typed. +Illegal application: +The term + "match + nth_error Bound (ibound idx) as anonymous'0 + return (anonymous'0 = nth_error Bound (ibound idx) -> e = e -> Prop) + with + | Some a => + match + e as anonymous' + return + (Some a = nth_error Bound (ibound idx) -> anonymous' = e -> Prop) + with + | Some a' => + fun (_ : Some a = nth_error Bound (ibound idx)) (_ : Some a' = e) => + a = a' + | None => + fun (_ : Some a = nth_error Bound (ibound idx)) (_ : None = e) => + True + end + | None => fun (_ : None = nth_error Bound (ibound idx)) (_ : e = e) => True + end" of type + "nth_error Bound (ibound idx) = nth_error Bound (ibound idx) -> + e = e -> Prop" +cannot be applied to the terms + "eq_refl" : "nth_error Bound (ibound idx) = nth_error Bound (ibound idx)" + "e0" : "nth_error Bound (ibound idx') = e" +The 2nd term has type "nth_error Bound (ibound idx') = e" +which should be coercible to "e = e". *) diff --git a/test-suite/bugs/opened/3357.v b/test-suite/bugs/opened/3357.v new file mode 100644 index 00000000..c4791588 --- /dev/null +++ b/test-suite/bugs/opened/3357.v @@ -0,0 +1,9 @@ +Notation D1 := (forall {T : Type} ( x : T ) , Type). + +Definition DD1 ( A : forall {T : Type} (x : T), Type ) := A 1. +Fail Definition DD1' ( A : D1 ) := A 1. (* Toplevel input, characters 32-33: +Error: In environment +A : forall T : Type, T -> Type +The term "1" has type "nat" while it is expected to have type +"Type". + *) diff --git a/test-suite/bugs/opened/3363.v b/test-suite/bugs/opened/3363.v new file mode 100644 index 00000000..800d8957 --- /dev/null +++ b/test-suite/bugs/opened/3363.v @@ -0,0 +1,26 @@ +(** In this file, either all four [Check]s should fail, or all four should succeed. *) +Module A. + Section HexStrings. + Require Import String. + End HexStrings. + Fail Check string. +End A. + +Module B. + Section HexStrings. + Require String. + Import String. + End HexStrings. + Fail Check string. +End B. + +Section HexStrings. + Require String. + Import String. +End HexStrings. +Fail Check string. + +Section HexStrings'. + Require Import String. +End HexStrings'. +Check string. diff --git a/test-suite/bugs/opened/3370.v b/test-suite/bugs/opened/3370.v new file mode 100644 index 00000000..4964bf96 --- /dev/null +++ b/test-suite/bugs/opened/3370.v @@ -0,0 +1,12 @@ +Require Import String. + +Local Ltac set_strings := + let s := match goal with |- context[String ?s1 ?s2] => constr:(String s1 s2) end in + let H := fresh s in + set (H := s). + +Local Open Scope string_scope. + +Goal "asdf" = "bds". +Fail set_strings. (* Error: Ltac variable s is bound to "asdf" which cannot be coerced to +a fresh identifier. *) diff --git a/test-suite/bugs/opened/3383.v b/test-suite/bugs/opened/3383.v new file mode 100644 index 00000000..9a14641a --- /dev/null +++ b/test-suite/bugs/opened/3383.v @@ -0,0 +1,7 @@ +Goal forall b : bool, match b as b' return if b' then True else True with true => I | false => I end = match b as b' return if b' then True else True with true => I | false => I end. +intro. +Fail lazymatch goal with +| [ |- appcontext[match ?b as b' return @?P b' with true => ?t | false => ?f end] ] + => change (match b as b' return P b with true => t | false => f end) with (@bool_rect P t f) +end. (* Toplevel input, characters 153-154: +Error: The reference P was not found in the current environment. *) diff --git a/test-suite/bugs/opened/3395.v b/test-suite/bugs/opened/3395.v new file mode 100644 index 00000000..ff0dbf97 --- /dev/null +++ b/test-suite/bugs/opened/3395.v @@ -0,0 +1,230 @@ +(* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines, 2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *) +Generalizable All Variables. +Set Implicit Arguments. + +Arguments fst {_ _} _. +Arguments snd {_ _} _. + +Axiom cheat : forall {T}, T. + +Reserved Notation "g 'o' f" (at level 40, left associativity). + +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (paths x y) : type_scope. + +Definition symmetry {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory (object : Type) := + Build_PreCategory' { + object :> Type := object; + morphism : object -> object -> Type; + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1); + associativity_sym : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + m3 o (m2 o m1) = (m3 o m2) o m1; + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f; + identity_identity : forall x, identity x o identity x = identity x + }. +Bind Scope category_scope with PreCategory. +Arguments PreCategory {_}. +Arguments identity {_} [!C%category] x%object : rename. + +Arguments compose {_} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + +Infix "o" := compose : morphism_scope. + +Delimit Scope functor_scope with functor. +Local Open Scope morphism_scope. +Record Functor `(C : @PreCategory objC, D : @PreCategory objD) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + composition_of : forall s d d' + (m1 : morphism C s d) (m2: morphism C d d'), + morphism_of _ _ (m2 o m1) + = (morphism_of _ _ m2) o (morphism_of _ _ m1); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) + }. +Bind Scope functor_scope with Functor. + +Arguments morphism_of {_} [C%category] {_} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. + +Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. + +Class IsIsomorphism `{C : @PreCategory objC} {s d} (m : morphism C s d) := + { + morphism_inverse : morphism C d s; + left_inverse : morphism_inverse o m = identity _; + right_inverse : m o morphism_inverse = identity _ + }. + +Definition opposite `(C : @PreCategory objC) : PreCategory + := @Build_PreCategory' + C + (fun s d => morphism C d s) + (identity (C := C)) + (fun _ _ _ m1 m2 => m2 o m1) + (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _ _) + (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _ _) + (fun _ _ => @right_identity _ _ _ _) + (fun _ _ => @left_identity _ _ _ _) + (@identity_identity _ C). + +Notation "C ^op" := (opposite C) (at level 3) : category_scope. + +Definition prod `(C : @PreCategory objC, D : @PreCategory objD) : @PreCategory (objC * objD). + refine (@Build_PreCategory' + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) + * morphism D (snd s) (snd d))%type) + (fun x => (identity (fst x), identity (snd x))) + (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1)) + _ + _ + _ + _ + _); admit. +Defined. +Infix "*" := prod : category_scope. + +Definition compose_functor `(C : @PreCategory objC, D : @PreCategory objD, E : @PreCategory objE) (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => morphism_of G (morphism_of F m)) + cheat + cheat. + +Infix "o" := compose_functor : functor_scope. + +Record NaturalTransformation `(C : @PreCategory objC, D : @PreCategory objD) (F G : Functor C D) := + Build_NaturalTransformation' { + components_of :> forall c, morphism D (F c) (G c); + commutes : forall s d (m : morphism C s d), + components_of d o F _1 m = G _1 m o components_of s; + + commutes_sym : forall s d (m : C.(morphism) s d), + G _1 m o components_of s = components_of d o F _1 m + }. +Definition functor_category `(C : @PreCategory objC, D : @PreCategory objD) : PreCategory + := @Build_PreCategory' (Functor C D) + (@NaturalTransformation _ C _ D) + cheat + cheat + cheat + cheat + cheat + cheat + cheat. + +Definition opposite_functor `(F : @Functor objC C objD D) : Functor C^op D^op + := Build_Functor (C^op) (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). + +Definition opposite_invL `(F : @Functor objC C^op objD D) : Functor C D^op + := Build_Functor C (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). +Notation "F ^op" := (opposite_functor F) : functor_scope. + +Notation "F ^op'L" := (opposite_invL F) (at level 3) : functor_scope. +Definition fst `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) C + := Build_Functor (C * D) C + (@fst _ _) + (fun _ _ => @fst _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). + +Definition snd `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) D + := Build_Functor (C * D) D + (@snd _ _) + (fun _ _ => @snd _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). +Definition prod_functor `(F : @Functor objC C objD D, F' : @Functor objC C objD' D') +: Functor C (D * D') + := Build_Functor + C (D * D') + (fun c => (F c, F' c)) + (fun s d m => (F _1 m, F' _1 m))%morphism + cheat + cheat. +Definition pair `(F : @Functor objC C objD D, F' : @Functor objC' C' objD' D') : Functor (C * C') (D * D') + := (prod_functor (F o fst) (F' o snd))%functor. +Notation cat_of obj := + (@Build_PreCategory' obj + (fun x y => forall _ : x, y) + (fun _ x => x) + (fun _ _ _ f g x => f (g x))%core + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ => idpath)). + +Definition hom_functor `(C : @PreCategory objC) : Functor (C^op * C) (cat_of Type) + := Build_Functor _ _ cheat cheat cheat cheat. + +Definition induced_hom_natural_transformation `(F : @Functor objC C objD D) +: NaturalTransformation (hom_functor C) (hom_functor D o pair F^op F) + := Build_NaturalTransformation' _ _ cheat cheat cheat. + +Class IsFullyFaithful `(F : @Functor objC C objD D) + := is_fully_faithful + : forall x y : C, + IsIsomorphism (induced_hom_natural_transformation F (x, y)). + +Definition coyoneda `(A : @PreCategory objA) : Functor A^op (@functor_category _ A _ (cat_of Type)) + := cheat. + +Definition yoneda `(A : @PreCategory objA) : Functor A (@functor_category _ A^op _ (cat_of Type)) + := (((coyoneda A^op)^op'L)^op'L)%functor. +Definition coyoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@coyoneda _ A). +Admitted. + +Definition yoneda_embedding_fast `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). +Proof. + intros a b. + pose proof (coyoneda_embedding A^op a b) as CYE. + unfold yoneda. + Time let t := (type of CYE) in + let t' := (eval simpl in t) in pose proof ((fun (x : t) => (x : t')) CYE) as CYE'. (* Finished transaction in 0. secs (0.216013u,0.004s) *) + Fail Timeout 1 let t := match goal with |- ?G => constr:(G) end in + let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). + Time let t := match goal with |- ?G => constr:(G) end in + let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). (* Finished transaction in 0. secs (0.248016u,0.s) *) +Fail Timeout 2 Defined. +Time Defined. (* Finished transaction in 1. secs (0.432027u,0.s) *) + +Definition yoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). +Proof. + intros a b. + pose proof (coyoneda_embedding A^op a b) as CYE. + unfold yoneda; simpl in *. + Fail Timeout 1 exact CYE. + Time exact CYE. (* Finished transaction in 0. secs (0.012001u,0.s) *) diff --git a/test-suite/bugs/opened/3410.v b/test-suite/bugs/opened/3410.v new file mode 100644 index 00000000..0d259181 --- /dev/null +++ b/test-suite/bugs/opened/3410.v @@ -0,0 +1 @@ +Fail repeat match goal with H:_ |- _ => setoid_rewrite X in H end. diff --git a/test-suite/bugs/opened/3459.v b/test-suite/bugs/opened/3459.v new file mode 100644 index 00000000..9e6107b3 --- /dev/null +++ b/test-suite/bugs/opened/3459.v @@ -0,0 +1,31 @@ +(* Bad interaction between clear and the typability of ltac constr bindings *) + +(* Original report *) + +Goal 1 = 2. +Proof. +(* This line used to fail with a Not_found up to some point, and then + to produce an ill-typed term *) +match goal with + | [ |- context G[2] ] => let y := constr:(fun x => $(let r := constr:(@eq Set x x) in + clear x; + exact r)$) in + pose y +end. +(* Add extra test for typability (should not fail when bug closed) *) +Fail match goal with P:?c |- _ => try (let x := type of c in idtac) || fail 2 end. +Abort. + +(* Second report raising a Not_found at the time of 21 Oct 2014 *) + +Section F. + +Variable x : nat. + +Goal True. +evar (e : Prop). +assert e. +Fail let r := constr:(eq_refl x) in clear x; exact r. +Abort. + +End F. diff --git a/test-suite/bugs/opened/3461.v b/test-suite/bugs/opened/3461.v new file mode 100644 index 00000000..1b625e6a --- /dev/null +++ b/test-suite/bugs/opened/3461.v @@ -0,0 +1,5 @@ +Lemma foo (b : bool) : + exists x : nat, x = x. +Proof. +eexists. +Fail eexact (eq_refl b). diff --git a/test-suite/bugs/opened/3463.v b/test-suite/bugs/opened/3463.v new file mode 100644 index 00000000..541db37f --- /dev/null +++ b/test-suite/bugs/opened/3463.v @@ -0,0 +1,13 @@ +Tactic Notation "test1" open_constr(t) ident(r):= + pose t. +Tactic Notation "test2" constr(r) open_constr(t):= + pose t. +Tactic Notation "test3" open_constr(t) constr(r):= + pose t. + +Goal True. + test1 (1 + _) nat. + test2 nat (1 + _). + test3 (1 + _) nat. + test3 (1 + _ : nat) nat. + diff --git a/test-suite/bugs/opened/3467.v b/test-suite/bugs/opened/3467.v new file mode 100644 index 00000000..900bfc34 --- /dev/null +++ b/test-suite/bugs/opened/3467.v @@ -0,0 +1,6 @@ +Module foo. + Notation x := $(exact I)$. +End foo. +Module bar. + Fail Include foo. +End bar. diff --git a/test-suite/bugs/opened/3478.v-disabled b/test-suite/bugs/opened/3478.v-disabled new file mode 100644 index 00000000..cc926b21 --- /dev/null +++ b/test-suite/bugs/opened/3478.v-disabled @@ -0,0 +1,8 @@ +Set Primitive Projections. +Record foo := { foom :> Type }. +Canonical Structure default_foo := fun T => {| foom := T |}. +Record bar T := { bar1 : T }. +Goal forall (s : foo) (x : foom s), True. +Proof. + intros. + Timeout 1 pose (x : bar _) as x'. \ No newline at end of file diff --git a/test-suite/bugs/opened/3490.v b/test-suite/bugs/opened/3490.v new file mode 100644 index 00000000..e7a5caa1 --- /dev/null +++ b/test-suite/bugs/opened/3490.v @@ -0,0 +1,27 @@ +Inductive T : Type := +| Var : nat -> T +| Arr : T -> T -> T. + +Inductive Tele : list T -> Type := +| Tnil : @Tele nil +| Tcons : forall ls, forall (t : @Tele ls) (l : T), @Tele (l :: ls). + +Fail Fixpoint TeleD (ls : list T) (t : Tele ls) {struct t} + : { x : Type & x -> nat -> Type } := + match t return { x : Type & x -> nat -> Type } with + | Tnil => @existT Type (fun x => x -> nat -> Type) unit (fun (_ : unit) (_ : nat) => unit) + | Tcons ls t' l => + let (result, get) := TeleD ls t' in + @existT Type (fun x => x -> nat -> Type) + { v : result & (fix TD (t : T) {struct t} := + match t with + | Var n => + get v n + | Arr a b => TD a -> TD b + end) l } + (fun x n => + match n return Type with + | 0 => projT2 x + | S n => get (projT1 x) n + end) + end. diff --git a/test-suite/bugs/opened/3491.v b/test-suite/bugs/opened/3491.v new file mode 100644 index 00000000..9837b0ec --- /dev/null +++ b/test-suite/bugs/opened/3491.v @@ -0,0 +1,2 @@ +Fail Inductive list (A : Type) (T := A) : Type := + nil : list A | cons : T -> list T -> list A. diff --git a/test-suite/bugs/opened/3509.v b/test-suite/bugs/opened/3509.v new file mode 100644 index 00000000..02e47a8b --- /dev/null +++ b/test-suite/bugs/opened/3509.v @@ -0,0 +1,18 @@ +Lemma match_bool_fn b A B xT xF +: match b as b return forall x : A, B b x with + | true => xT + | false => xF + end + = fun x : A => match b as b return B b x with + | true => xT x + | false => xF x + end. +admit. +Defined. +Lemma match_bool_comm_1 (b : bool) A B (F : forall x : A, B x) t f +: (if b as b return B (if b then t else f) then F t else F f) + = F (if b then t else f). +admit. +Defined. +Hint Rewrite match_bool_fn : matchdb. +Fail Hint Rewrite match_bool_comm_1 : matchdb. diff --git a/test-suite/bugs/opened/3510.v b/test-suite/bugs/opened/3510.v new file mode 100644 index 00000000..25285636 --- /dev/null +++ b/test-suite/bugs/opened/3510.v @@ -0,0 +1,34 @@ +Lemma match_option_fn T (b : option T) A B s n +: match b as b return forall x : A, B b x with + | Some k => s k + | None => n + end + = fun x : A => match b as b return B b x with + | Some k => s k x + | None => n x + end. +admit. +Defined. +Lemma match_option_comm_2 T (p : option T) A B R (f : forall (x : A) (y : B x), R x y) (s1 : T -> A) (s2 : forall x : T, B (s1 x)) n1 n2 +: match p as p return R match p with + | Some k => s1 k + | None => n1 + end + match p as p return B match p with Some k => s1 k | None => n1 end with + | Some k => s2 k + | None => n2 + end with + | Some k => f (s1 k) (s2 k) + | None => f n1 n2 + end + = f match p return A with + | Some k => s1 k + | None => n1 + end + match p as p return B match p with Some k => s1 k | None => n1 end with + | Some k => s2 k + | None => n2 + end. +admit. +Defined. +Fail Hint Rewrite match_option_fn match_option_comm_2 : matchdb. diff --git a/test-suite/bugs/opened/3554.v b/test-suite/bugs/opened/3554.v new file mode 100644 index 00000000..422c5770 --- /dev/null +++ b/test-suite/bugs/opened/3554.v @@ -0,0 +1 @@ +Fail Example foo (f : forall {_ : Type}, Type) : Type. diff --git a/test-suite/bugs/opened/3562.v b/test-suite/bugs/opened/3562.v new file mode 100644 index 00000000..04a1223b --- /dev/null +++ b/test-suite/bugs/opened/3562.v @@ -0,0 +1,2 @@ +Theorem t: True. +Fail destruct 0 as x. diff --git a/test-suite/bugs/opened/3626.v b/test-suite/bugs/opened/3626.v new file mode 100644 index 00000000..46a6c009 --- /dev/null +++ b/test-suite/bugs/opened/3626.v @@ -0,0 +1,7 @@ +Set Implicit Arguments. +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. + +Fail Goal forall x y : prod Set Set, x.(@fst) = y.(@fst). +(* intros. + apply f_equal. *) diff --git a/test-suite/bugs/opened/3655.v b/test-suite/bugs/opened/3655.v new file mode 100644 index 00000000..841f77fe --- /dev/null +++ b/test-suite/bugs/opened/3655.v @@ -0,0 +1,9 @@ +Ltac bar x := pose x. +Tactic Notation "foo" open_constr(x) := bar x. +Class baz := { baz' : Type }. +Goal True. +(* Original error was an anomaly which is fixed; now, it succeeds but + leaving an evar, while calling pose would not leave an evar, so I + guess it is still a bug in the sense that the semantics of pose is + not preserved *) + foo baz'. diff --git a/test-suite/bugs/opened/3657.v b/test-suite/bugs/opened/3657.v new file mode 100644 index 00000000..6faec076 --- /dev/null +++ b/test-suite/bugs/opened/3657.v @@ -0,0 +1,33 @@ +(* Set Primitive Projections. *) +Class foo {A} {a : A} := { bar := a; baz : bar = bar }. +Arguments bar {_} _ {_}. +Instance: forall A a, @foo A a. +intros; constructor. +abstract reflexivity. +Defined. +Goal @bar _ Set _ = (@bar _ (fun _ : Set => Set) _) nat. +Proof. + Check (bar Set). + Check (bar (fun _ : Set => Set)). + Fail change (bar (fun _ : Set => Set)) with (bar Set). (* Error: Conversion test raised an anomaly *) + +Abort. + + +Module A. +Universes i j. +Constraint i < j. +Variable foo : Type@{i}. +Goal Type@{i}. + Fail let t := constr:(Type@{j}) in + change Type with t. +Abort. + +Goal Type@{j}. + Fail let t := constr:(Type@{i}) in + change Type with t. + let t := constr:(Type@{i}) in + change t. exact foo. +Defined. + +End A. diff --git a/test-suite/bugs/opened/3670.v b/test-suite/bugs/opened/3670.v new file mode 100644 index 00000000..cf5e9b09 --- /dev/null +++ b/test-suite/bugs/opened/3670.v @@ -0,0 +1,19 @@ +Module Type FOO. + Parameters P Q : Type -> Type. +End FOO. + +Module Type BAR. + Declare Module Export foo : FOO. + Parameter f : forall A, P A -> Q A -> A. +End BAR. + +Module Type BAZ. + Declare Module Export foo : FOO. + Parameter g : forall A, P A -> Q A -> A. +End BAZ. + +Module BAR_FROM_BAZ (baz : BAZ) : BAR. + Import baz. + Module foo <: FOO := foo. + Definition f : forall A, P A -> Q A -> A := g. +End BAR_FROM_BAZ. diff --git a/test-suite/bugs/opened/3675.v b/test-suite/bugs/opened/3675.v new file mode 100644 index 00000000..93227ab8 --- /dev/null +++ b/test-suite/bugs/opened/3675.v @@ -0,0 +1,20 @@ +Set Primitive Projections. +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end. +Notation "p @ q" := (concat p q) (at level 20) : path_scope. +Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : forall x, f (equiv_inv x) = x }. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. +Local Open Scope path_scope. +Local Open Scope equiv_scope. +Generalizable Variables A B C f g. +Lemma isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} +: IsEquiv (compose g f). +Proof. + refine (Build_IsEquiv A C + (compose g f) + (compose f^-1 g^-1) _). + exact (fun c => ap g (@eisretr _ _ f _ (g^-1 c)) @ (@eisretr _ _ g _ c)). diff --git a/test-suite/bugs/opened/3681.v b/test-suite/bugs/opened/3681.v new file mode 100644 index 00000000..194113c6 --- /dev/null +++ b/test-suite/bugs/opened/3681.v @@ -0,0 +1,20 @@ +Module Type FOO. + Parameters P Q : Type -> Type. +End FOO. + +Module Type BAR. + Declare Module Import foo : FOO. + Parameter f : forall A, P A -> Q A -> A. +End BAR. + +Module Type BAZ. + Declare Module Export foo : FOO. + Parameter g : forall A, P A -> Q A -> A. +End BAZ. + +Module BAR_FROM_BAZ (baz : BAZ) : BAR. + Import baz. + Module foo <: FOO := foo. + Import foo. + Definition f : forall A, P A -> Q A -> A := g. +End BAR_FROM_BAZ. diff --git a/test-suite/bugs/opened/3685.v b/test-suite/bugs/opened/3685.v new file mode 100644 index 00000000..d647b5a8 --- /dev/null +++ b/test-suite/bugs/opened/3685.v @@ -0,0 +1,74 @@ +Set Universe Polymorphism. +Class Funext := { }. +Delimit Scope category_scope with category. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Set Implicit Arguments. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); + identity_of : forall s m, morphism_of s s m = morphism_of s s m }. +Definition sub_pre_cat `{Funext} (P : PreCategory -> Type) : PreCategory. +Proof. + exact (@Build_PreCategory PreCategory Functor). +Defined. +Definition opposite (C : PreCategory) : PreCategory. +Proof. + exact (@Build_PreCategory C (fun s d => morphism C d s)). +Defined. +Local Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope. +Definition prod (C D : PreCategory) : PreCategory. +Proof. + refine (@Build_PreCategory + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type)). +Defined. +Local Infix "*" := prod : category_scope. +Record NaturalTransformation C D (F G : Functor C D) := {}. +Definition functor_category (C D : PreCategory) : PreCategory. +Proof. + exact (@Build_PreCategory (Functor C D) (@NaturalTransformation C D)). +Defined. +Local Notation "C -> D" := (functor_category C D) : category_scope. +Module Export PointwiseCore. + Local Open Scope category_scope. + Definition pointwise + (C C' : PreCategory) + (F : Functor C' C) + (D D' : PreCategory) + (G : Functor D D') + : Functor (C -> D) (C' -> D'). + Proof. + refine (Build_Functor + (C -> D) (C' -> D') + _ + _ + _); + abstract admit. + Defined. +End PointwiseCore. +Axiom Pidentity_of : forall (C D : PreCategory) (F : Functor C C) (G : Functor D D), pointwise F G = pointwise F G. +Local Open Scope category_scope. +Module Success. + Definition functor_uncurried `{Funext} (P : PreCategory -> Type) + (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) + : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) + := Eval cbv zeta in + let object_of := (fun CD => (((fst CD) -> (snd CD)))) + in Build_Functor + ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P) + object_of + (fun CD C'D' FG => pointwise (fst FG) (snd FG)) + (fun _ _ => @Pidentity_of _ _ _ _). +End Success. +Module Bad. + Include PointwiseCore. + Fail Definition functor_uncurried `{Funext} (P : PreCategory -> Type) + (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) + : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) + := Eval cbv zeta in + let object_of := (fun CD => (((fst CD) -> (snd CD)))) + in Build_Functor + ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P) + object_of + (fun CD C'D' FG => pointwise (fst FG) (snd FG)) + (fun _ _ => @Pidentity_of _ _ _ _). diff --git a/test-suite/bugs/opened/3753.v b/test-suite/bugs/opened/3753.v new file mode 100644 index 00000000..05d77c83 --- /dev/null +++ b/test-suite/bugs/opened/3753.v @@ -0,0 +1,4 @@ +Axiom foo : Type -> Type. +Axiom bar : forall (T : Type), T -> foo T. +Arguments bar A x : rename. +Fail About bar. diff --git a/test-suite/bugs/opened/3754.v b/test-suite/bugs/opened/3754.v new file mode 100644 index 00000000..c7441882 --- /dev/null +++ b/test-suite/bugs/opened/3754.v @@ -0,0 +1,282 @@ +(* File reduced by coq-bug-finder from original input, then from 9113 lines to 279 lines *) +(* coqc version trunk (October 2014) compiled on Oct 19 2014 18:56:9 with OCaml 3.12.1 + coqtop version trunk (October 2014) *) + +Notation Type0 := Set. + +Notation idmap := (fun x => x). + +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. + +Notation pr1 := projT1. + +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. + +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := + fun x => g (f x). + +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. +Open Scope function_scope. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x. +admit. +Defined. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. + +Notation "1" := idpath : path_scope. + +Notation "p @ q" := (concat p q) (at level 20) : path_scope. + +Notation "p ^" := (inverse p) (at level 3, format "p '^'") : path_scope. + +Notation "p @' q" := (concat p q) (at level 21, left associativity, + format "'[v' p '/' '@'' q ']'") : long_path_scope. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y. +exact (match p with idpath => u end). +Defined. + +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y. +exact (match p with idpath => idpath end). +Defined. + +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) + := forall x:A, f x = g x. + +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Arguments eisretr {A B} f {_} _. + +Record Equiv A B := BuildEquiv { + equiv_fun : A -> B ; + equiv_isequiv : IsEquiv equiv_fun +}. + +Coercion equiv_fun : Equiv >-> Funclass. + +Global Existing Instance equiv_isequiv. + +Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) +}. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope. +Local Open Scope trunc_scope. +Notation "-2" := minus_two (at level 0) : trunc_scope. +Notation "-1" := (-2.+1) (at level 0) : trunc_scope. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | -2 => Contr_internal A + | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. +Notation IsHProp := (IsTrunc -1). + +Monomorphic Axiom dummy_funext_type : Type0. +Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }. + +Local Open Scope path_scope. + +Definition concat_p1 {A : Type} {x y : A} (p : x = y) : + p @ 1 = p + := + match p with idpath => 1 end. + +Definition concat_1p {A : Type} {x y : A} (p : x = y) : + 1 @ p = p + := + match p with idpath => 1 end. + +Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : + p @ (q @ r) = (p @ q) @ r := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. + +Definition concat_pp_p {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : + (p @ q) @ r = p @ (q @ r) := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. + +Definition moveL_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : + r^ @ q = p -> q = r @ p. +admit. +Defined. + +Ltac with_rassoc tac := + repeat rewrite concat_pp_p; + tac; + + repeat rewrite concat_p_pp. + +Ltac rewrite_moveL_Mp_p := with_rassoc ltac:(apply moveL_Mp). + +Definition ap_p_pp {A B : Type} (f : A -> B) {w : B} {x y z : A} + (r : w = f x) (p : x = y) (q : y = z) : + r @ (ap f (p @ q)) = (r @ ap f p) @ (ap f q). +admit. +Defined. + +Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) : + ap (g o f) p = ap g (ap f p) + := + match p with idpath => 1 end. + +Definition concat_Ap {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) : + (ap f q) @ (p y) = (p x) @ (ap g q) + := + match q with + | idpath => concat_1p _ @ ((concat_p1 _) ^) + end. + +Definition transportD2 {A : Type} (B C : A -> Type) (D : forall a:A, B a -> C a -> Type) + {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1) (w : D x1 y z) + : D x2 (p # y) (p # z) + := + match p with idpath => w end. +Local Open Scope equiv_scope. + +Definition transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type} + {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) (y : B x2) + : (transport (fun x => B x -> C) p f) y = f (p^ # y). +admit. +Defined. + +Definition transport_arrow_fromconst {A B : Type} {C : A -> Type} + {x1 x2 : A} (p : x1 = x2) (f : B -> C x1) (y : B) + : (transport (fun x => B -> C x) p f) y = p # (f y). +admit. +Defined. + +Definition ap_transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type} + {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) {y1 y2 : B x2} (q : y1 = y2) + : ap (transport (fun x => B x -> C) p f) q + @ transport_arrow_toconst p f y2 + = transport_arrow_toconst p f y1 + @ ap (fun y => f (p^ # y)) q. +admit. +Defined. + +Class Univalence. +Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B). +admit. +Defined. +Definition transport_path_universe + {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A) + : transport (fun X:Type => X) (path_universe f) z = f z. +admit. +Defined. +Definition transport_path_universe_V `{Funext} + {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : B) + : transport (fun X:Type => X) (path_universe f)^ z = f^-1 z. +admit. +Defined. + +Ltac simpl_do_clear tac term := + let H := fresh in + assert (H := term); + simpl in H |- *; + tac H; + clear H. + +Tactic Notation "simpl" "rewrite" constr(term) := simpl_do_clear ltac:(fun H => rewrite H) term. + +Global Instance Univalence_implies_Funext `{Univalence} : Funext. +Admitted. + +Section Factorization. + + Context {class1 class2 : forall (X Y : Type@{i}), (X -> Y) -> Type@{i}} + `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class1 _ _ g)} + `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class2 _ _ g)} + {A B : Type@{i}} {f : A -> B}. + + Record Factorization := + { intermediate : Type ; + factor1 : A -> intermediate ; + factor2 : intermediate -> B ; + fact_factors : factor2 o factor1 == f ; + inclass1 : class1 _ _ factor1 ; + inclass2 : class2 _ _ factor2 + }. + + Record PathFactorization {fact fact' : Factorization} := + { path_intermediate : intermediate fact <~> intermediate fact' ; + path_factor1 : path_intermediate o factor1 fact == factor1 fact' ; + path_factor2 : factor2 fact == factor2 fact' o path_intermediate ; + path_fact_factors : forall a, path_factor2 (factor1 fact a) + @ ap (factor2 fact') (path_factor1 a) + @ fact_factors fact' a + = fact_factors fact a + }. + Context `{Univalence} {fact fact' : Factorization} + (pf : @PathFactorization fact fact'). + + Let II := path_intermediate pf. + Let ff1 := path_factor1 pf. + Let ff2 := path_factor2 pf. +Local Definition II' : intermediate fact = intermediate fact'. +admit. +Defined. + + Local Definition fff' (a : A) + : (transportD2 (fun X => A -> X) (fun X => X -> B) + (fun X g h => {_ : forall a : A, h (g a) = f a & + {_ : class1 A X g & class2 X B h}}) + II' (factor1 fact) (factor2 fact) + (fact_factors fact; (inclass1 fact; inclass2 fact))).1 a = + ap (transport (fun X => X -> B) II' (factor2 fact)) + (transport_arrow_fromconst II' (factor1 fact) a + @ transport_path_universe II (factor1 fact a) + @ ff1 a) + @ transport_arrow_toconst II' (factor2 fact) (factor1 fact' a) + @ ap (factor2 fact) (transport_path_universe_V II (factor1 fact' a)) + @ ff2 (II^-1 (factor1 fact' a)) + @ ap (factor2 fact') (eisretr II (factor1 fact' a)) + @ fact_factors fact' a. + Proof. + + Open Scope long_path_scope. + + rewrite (ap_transport_arrow_toconst (B := idmap) (C := B)). + + simpl rewrite (@ap_compose _ _ _ (transport idmap (path_universe II)^) + (factor2 fact)). + rewrite <- ap_p_pp; rewrite_moveL_Mp_p. + Set Debug Tactic Unification. + Fail rewrite (concat_Ap ff2). diff --git a/test-suite/bugs/opened/3786.v b/test-suite/bugs/opened/3786.v new file mode 100644 index 00000000..5a124115 --- /dev/null +++ b/test-suite/bugs/opened/3786.v @@ -0,0 +1,40 @@ +Require Coq.Lists.List. +Require Coq.Sets.Ensembles. +Import Coq.Sets.Ensembles. +Global Set Implicit Arguments. +Delimit Scope comp_scope with comp. +Inductive Comp : Type -> Type := +| Return : forall A, A -> Comp A +| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B +| Pick : forall A, Ensemble A -> Comp A. +Notation ret := Return. +Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp)) + (at level 81, right associativity, + format "'[v' x <- y ; '/' z ']'") : comp_scope. +Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop. +Open Scope comp. +Axiom elements : forall {A} (ls : list A), Ensemble A. +Axiom to_list : forall {A} (S : Ensemble A), Comp (list A). +Axiom finite_set_handle_cardinal : refine (ret 0) (ret 0). +Definition sumUniqueSpec (ls : list nat) : Comp nat. + exact (ls' <- to_list (elements ls); + List.fold_right (fun a b' => Bind b' ((fun a b => ret (a + b)) a)) (ret 0) ls'). +Defined. +Axiom admit : forall {T}, T. +Definition sumUniqueImpl (ls : list nat) +: { c : _ | refine (sumUniqueSpec ls) (ret c) }%type. +Proof. + eexists. + match goal with + | [ |- refine ?a ?b ] => let a' := eval hnf in a in refine (_ : refine a' b) + end; + try setoid_rewrite (@finite_set_handle_cardinal). + Undo. + match goal with + | [ |- refine ?a ?b ] => let a' := eval hnf in a in change (refine a' b) + end. + try setoid_rewrite (@finite_set_handle_cardinal). (* Anomaly: Uncaught exception Invalid_argument("decomp_pointwise"). +Please report. *) + instantiate (1 := admit). + admit. +Defined. diff --git a/test-suite/bugs/opened/3788.v b/test-suite/bugs/opened/3788.v new file mode 100644 index 00000000..8e605a00 --- /dev/null +++ b/test-suite/bugs/opened/3788.v @@ -0,0 +1,5 @@ +Set Implicit Arguments. +Global Set Primitive Projections. +Record Functor (C D : Type) := { object_of :> forall _ : C, D }. +Axiom path_functor_uncurried : forall C D (F G : Functor C D) (_ : sigT (fun HO : object_of F = object_of G => Set)), F = G. +Fail Lemma path_functor_uncurried_snd C D F G HO HM : (@path_functor_uncurried C D F G (existT _ HO HM)) = HM. diff --git a/test-suite/bugs/opened/3808.v b/test-suite/bugs/opened/3808.v new file mode 100644 index 00000000..df40ca19 --- /dev/null +++ b/test-suite/bugs/opened/3808.v @@ -0,0 +1,2 @@ +Inductive Foo : (let enforce := (fun x => x) : Type@{j} -> Type@{i} in Type@{i}) + := foo : Foo. diff --git a/test-suite/bugs/opened/3819.v b/test-suite/bugs/opened/3819.v new file mode 100644 index 00000000..7105a658 --- /dev/null +++ b/test-suite/bugs/opened/3819.v @@ -0,0 +1,11 @@ +Set Universe Polymorphism. + +Record Op := { t : Type ; op : t -> t }. + +Canonical Structure OpType : Op := Build_Op Type (fun X => X). + +Lemma test1 (X:Type) : eq (op OpType X) X. +Proof eq_refl. + +Lemma test2 (A:Type) : eq (op _ A) A. +Fail Proof eq_refl. diff --git a/test-suite/bugs/opened/3849.v b/test-suite/bugs/opened/3849.v new file mode 100644 index 00000000..5290054a --- /dev/null +++ b/test-suite/bugs/opened/3849.v @@ -0,0 +1,8 @@ +Tactic Notation "foo" hyp_list(hs) := clear hs. + +Tactic Notation "bar" hyp_list(hs) := foo hs. + +Goal True. +do 5 pose proof 0 as ?n0. +foo n1 n2. +Fail bar n3 n4. diff --git a/test-suite/bugs/opened/743.v b/test-suite/bugs/opened/743.v new file mode 100644 index 00000000..28257014 --- /dev/null +++ b/test-suite/bugs/opened/743.v @@ -0,0 +1,12 @@ +Require Import Omega. + +Lemma foo : forall n m : Z, (n >= 0)%Z -> (n * m >= 0)%Z -> (n <= n + n * m)%Z. +Proof. + intros. omega. +Qed. + +Lemma foo' : forall n m : nat, n <= n + n * m. +Proof. + intros. Fail omega. +Abort. + diff --git a/test-suite/bugs/opened/HoTT_coq_106.v b/test-suite/bugs/opened/HoTT_coq_106.v new file mode 100644 index 00000000..a5664595 --- /dev/null +++ b/test-suite/bugs/opened/HoTT_coq_106.v @@ -0,0 +1,52 @@ +(* File reduced by coq-bug-finder from 520 lines to 9 lines. *) +Set Universe Polymorphism. +Class IsPointed (A : Type) := point : A. + +Generalizable Variables A B f. + +Instance ispointed_forall `{H : forall a : A, IsPointed (B a)} +: IsPointed (forall a, B a) + := fun a => @point (B a) (H a). + +Instance ispointed_sigma `{IsPointed A} `{IsPointed (B (point A))} +: IsPointed (sigT B). +(* Message was at some time: +Toplevel input, characters 20-108: +Error: Unable to satisfy the following constraints: +UNDEFINED EVARS: + ?8==[A H B |- IsPointed (forall x : Type, ?13)] (parameter IsPointed of + @point) + ?12==[A H {B} x |- Type] (parameter A of @point) + ?13==[A H {B} x |- Type] (parameter A of @point) + ?15==[A H {B} x |- Type] (parameter A of @point)UNIVERSES: + {Top.38 Top.30 Top.39 Top.40 Top.29 Top.36 Top.31 Top.35 Top.37 Top.34 Top.32 Top.33} |= Top.30 < Top.29 + Top.30 < Top.36 + Top.32 < Top.34 + Top.38 <= Top.37 + Top.38 <= Top.33 + Top.40 <= Top.38 + Top.40 <= Coq.Init.Specif.7 + Top.40 <= Top.39 + Top.36 <= Top.35 + Top.37 <= Top.35 + Top.34 <= Top.31 + Top.32 <= Top.39 + Top.32 <= Coq.Init.Specif.8 + Top.33 <= Top.31 + +ALGEBRAIC UNIVERSES: + {Top.38 Top.40 Top.29 Top.36 Top.31 Top.37 Top.34 Top.33} +UNDEFINED UNIVERSES: + Top.38 + Top.30 + Top.39 + Top.40 + Top.29 + Top.36 + Top.31 + Top.35 + Top.37 + Top.34 + Top.32 + Top.33CONSTRAINTS:[] [A H B] |- ?13 == ?12 +[] [A H B H0] |- ?12 == ?15 *) diff --git a/test-suite/bugs/opened/HoTT_coq_120.v b/test-suite/bugs/opened/HoTT_coq_120.v new file mode 100644 index 00000000..7847c5e4 --- /dev/null +++ b/test-suite/bugs/opened/HoTT_coq_120.v @@ -0,0 +1,136 @@ +(* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines *) +Set Universe Polymorphism. +Generalizable All Variables. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (@paths _ x y) : type_scope. + +Class IsEquiv {A B : Type} (f : A -> B) := {}. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) + }. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint nat_to_trunc_index (n : nat) : trunc_index + := match n with + | 0 => trunc_S (trunc_S minus_two) + | S n' => trunc_S (nat_to_trunc_index n') + end. + +Coercion nat_to_trunc_index : nat >-> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Notation minus_one:=(trunc_S minus_two). + +Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. + +Notation Contr := (IsTrunc minus_two). +Notation IsHProp := (IsTrunc minus_one). +Notation IsHSet := (IsTrunc 0). + +Class Funext := {}. +Inductive Unit : Set := tt. + +Instance contr_unit : Contr Unit | 0 := let x := {| + center := tt; + contr := fun t : Unit => match t with tt => idpath end + |} in x. +Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. +admit. +Defined. +Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. +Definition Unit_hp:hProp:=(hp Unit _). +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). +Definition ismono {X Y} (f : X -> Y) + := forall Z : hSet, + forall g h : Z -> X, (fun x => f (g x)) = (fun x => f (h x)) -> g = h. + +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory := + Build_PreCategory { + object :> Type; + morphism : object -> object -> Type; + compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' + }. +Arguments compose [!C s d d'] m1 m2 : rename. + +Infix "o" := compose : morphism_scope. +Local Open Scope morphism_scope. + +Class IsEpimorphism {C} {x y} (m : morphism C x y) := + is_epimorphism : forall z (m1 m2 : morphism C y z), + m1 o m = m2 o m + -> m1 = m2. + +Class IsMonomorphism {C} {x y} (m : morphism C x y) := + is_monomorphism : forall z (m1 m2 : morphism C z x), + m o m1 = m o m2 + -> m1 = m2. +Class Univalence := {}. +Global Instance isset_hProp `{Funext} : IsHSet hProp | 0. Admitted. + +Definition set_cat : PreCategory + := @Build_PreCategory hSet + (fun x y => forall _ : x, y)%core + (fun _ _ _ f g x => f (g x))%core. +Local Inductive minus1Trunc (A :Type) : Type := min1 : A -> minus1Trunc A. +Instance minus1Trunc_is_prop {A : Type} : IsHProp (minus1Trunc A) | 0. Admitted. +Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT P). +Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, + forall g h: Y -> Z, (fun x => g (f x)) = (fun x => h (f x)) -> g = h. +Definition issurj {X Y} (f:X->Y) := forall y:Y , hexists (fun x => (f x) = y). +Lemma isepi_issurj `{fs:Funext} `{ua:Univalence} `{fs' : Funext} {X Y} (f:X->Y): isepi f -> issurj f. +Proof. + intros epif y. + set (g :=fun _:Y => Unit_hp). + set (h:=(fun y:Y => (hp (hexists (fun _ : Unit => {x:X & y = (f x)})) _ ))). + clear fs'. + hnf in epif. + specialize (epif (BuildhSet hProp _) g h). + admit. +Defined. +Definition isequiv_isepi_ismono `{Univalence, fs0 : Funext} (X Y : hSet) (f : X -> Y) (epif : isepi f) (monof : ismono f) +: IsEquiv f. +Proof. + pose proof (@isepi_issurj _ _ _ _ _ f epif) as surjf. + admit. +Defined. +Section fully_faithful_helpers. + Context `{fs0 : Funext}. + Variables x y : hSet. + Variable m : x -> y. + + Let isequiv_isepi_ismono_helper ua := (@isequiv_isepi_ismono ua fs0 x y m : isepi m -> ismono m -> IsEquiv m). + + Goal True. + Fail set (isequiv_isepimorphism_ismonomorphism + := fun `{Univalence} + (Hepi : IsEpimorphism (m : morphism set_cat x y)) + (Hmono : IsMonomorphism (m : morphism set_cat x y)) + => (@isequiv_isepi_ismono_helper _ Hepi Hmono : @IsEquiv _ _ m)). + admit. + Undo. + Fail set (isequiv_isepimorphism_ismonomorphism' + := fun `{Univalence} + (Hepi : IsEpimorphism (m : morphism set_cat x y)) + (Hmono : IsMonomorphism (m : morphism set_cat x y)) + => ((let _ := @isequiv_isepimorphism_ismonomorphism _ Hepi Hmono in @isequiv_isepi_ismono _ fs0 x y m Hepi Hmono) + : @IsEquiv _ _ m)). + Set Printing Universes. + admit. (* Error: Universe inconsistency (cannot enforce Top.235 <= Set because Set +< Top.235). *) diff --git a/test-suite/bugs/opened/shouldnotfail/1338.v-disabled b/test-suite/bugs/opened/shouldnotfail/1338.v-disabled deleted file mode 100644 index f383d534..00000000 --- a/test-suite/bugs/opened/shouldnotfail/1338.v-disabled +++ /dev/null @@ -1,12 +0,0 @@ -Require Import Omega. - -Goal forall x, 0 <= x -> x <= 20 -> -x <> 0 - -> x <> 1 -> x <> 2 -> x <> 3 -> x <>4 -> x <> 5 -> x <> 6 -> x <> 7 -> x <> 8 --> x <> 9 -> x <> 10 - -> x <> 11 -> x <> 12 -> x <> 13 -> x <> 14 -> x <> 15 -> x <> 16 -> x <> 17 --> x <> 18 -> x <> 19 -> x <> 20 -> False. -Proof. - intros. - omega. -Qed. diff --git a/test-suite/bugs/opened/shouldnotfail/1501.v b/test-suite/bugs/opened/shouldnotfail/1501.v deleted file mode 100644 index 1845dd1f..00000000 --- a/test-suite/bugs/opened/shouldnotfail/1501.v +++ /dev/null @@ -1,93 +0,0 @@ -Set Implicit Arguments. - - -Require Export Relation_Definitions. -Require Export Setoid. - - -Section Essais. - -(* Parametrized Setoid *) -Parameter K : Type -> Type. -Parameter equiv : forall A : Type, K A -> K A -> Prop. -Parameter equiv_refl : forall (A : Type) (x : K A), equiv x x. -Parameter equiv_sym : forall (A : Type) (x y : K A), equiv x y -> equiv y x. -Parameter equiv_trans : forall (A : Type) (x y z : K A), equiv x y -> equiv y z --> equiv x z. - -(* basic operations *) -Parameter val : forall A : Type, A -> K A. -Parameter bind : forall A B : Type, K A -> (A -> K B) -> K B. - -Parameter - bind_compat : - forall (A B : Type) (m1 m2 : K A) (f1 f2 : A -> K B), - equiv m1 m2 -> - (forall x : A, equiv (f1 x) (f2 x)) -> equiv (bind m1 f1) (bind m2 f2). - -(* monad axioms *) -Parameter - bind_val_l : - forall (A B : Type) (a : A) (f : A -> K B), equiv (bind (val a) f) (f a). -Parameter - bind_val_r : - forall (A : Type) (m : K A), equiv (bind m (fun a => val a)) m. -Parameter - bind_assoc : - forall (A B C : Type) (m : K A) (f : A -> K B) (g : B -> K C), - equiv (bind (bind m f) g) (bind m (fun a => bind (f a) g)). - - -Hint Resolve equiv_refl equiv_sym equiv_trans: monad. - -Add Relation K equiv - reflexivity proved by (@equiv_refl) - symmetry proved by (@equiv_sym) - transitivity proved by (@equiv_trans) - as equiv_rel. - -Definition fequiv (A B: Type) (f g: A -> K B) := forall (x:A), (equiv (f x) (g -x)). - -Lemma fequiv_refl : forall (A B: Type) (f : A -> K B), fequiv f f. -Proof. - unfold fequiv; auto with monad. -Qed. - -Lemma fequiv_sym : forall (A B: Type) (x y : A -> K B), fequiv x y -> fequiv y -x. -Proof. - unfold fequiv; auto with monad. -Qed. - -Lemma fequiv_trans : forall (A B: Type) (x y z : A -> K B), fequiv x y -> -fequiv -y z -> fequiv x z. -Proof. - unfold fequiv; intros; eapply equiv_trans; auto with monad. -Qed. - -Add Relation (fun (A B:Type) => A -> K B) fequiv - reflexivity proved by (@fequiv_refl) - symmetry proved by (@fequiv_sym) - transitivity proved by (@fequiv_trans) - as fequiv_rel. - -Add Morphism bind - with signature equiv ==> fequiv ==> equiv - as bind_mor. -Proof. - unfold fequiv; intros; apply bind_compat; auto. -Qed. - -Lemma test: - forall (A B: Type) (m1 m2 m3: K A) (f: A -> A -> K B), - (equiv m1 m2) -> (equiv m2 m3) -> - equiv (bind m1 (fun a => bind m2 (fun a' => f a a'))) - (bind m2 (fun a => bind m3 (fun a' => f a a'))). -Proof. - intros A B m1 m2 m3 f H1 H2. - setoid_rewrite H1. (* this works *) - setoid_rewrite H2. - trivial by equiv_refl. -Qed. diff --git a/test-suite/bugs/opened/shouldnotfail/1596.v b/test-suite/bugs/opened/shouldnotfail/1596.v deleted file mode 100644 index de77e35d..00000000 --- a/test-suite/bugs/opened/shouldnotfail/1596.v +++ /dev/null @@ -1,242 +0,0 @@ - -Require Import Relations. -Require Import FSets. -Require Import Arith. - -Lemma Bool_elim_bool : forall (b:bool),b=true \/ b=false. - destruct b;try tauto. -Qed. - -Module OrderedPair (X:OrderedType) (Y:OrderedType) <: OrderedType with -Definition t := (X.t * Y.t)%type. - Definition t := (X.t * Y.t)%type. - - Definition eq (xy1:t) (xy2:t) := - let (x1,y1) := xy1 in - let (x2,y2) := xy2 in - (X.eq x1 x2) /\ (Y.eq y1 y2). - - Definition lt (xy1:t) (xy2:t) := - let (x1,y1) := xy1 in - let (x2,y2) := xy2 in - (X.lt x1 x2) \/ ((X.eq x1 x2) /\ (Y.lt y1 y2)). - - Lemma eq_refl : forall (x:t),(eq x x). - destruct x. - unfold eq. - split;[apply X.eq_refl | apply Y.eq_refl]. - Qed. - - Lemma eq_sym : forall (x y:t),(eq x y)->(eq y x). - destruct x;destruct y;unfold eq;intro. - elim H;clear H;intros. - split;[apply X.eq_sym | apply Y.eq_sym];trivial. - Qed. - - Lemma eq_trans : forall (x y z:t),(eq x y)->(eq y z)->(eq x z). - unfold eq;destruct x;destruct y;destruct z;intros. - elim H;clear H;intros. - elim H0;clear H0;intros. - split;[eapply X.eq_trans | eapply Y.eq_trans];eauto. - Qed. - - Lemma lt_trans : forall (x y z:t),(lt x y)->(lt y z)->(lt x z). - unfold lt;destruct x;destruct y;destruct z;intros. - case H;clear H;intro. - case H0;clear H0;intro. - left. - eapply X.lt_trans;eauto. - elim H0;clear H0;intros. - left. - case (X.compare t0 t4);trivial;intros. - generalize (X.eq_sym H0);intro. - generalize (X.eq_trans e H2);intro. - elim (X.lt_not_eq H H3). - generalize (X.lt_trans l H);intro. - generalize (X.eq_sym H0);intro. - elim (X.lt_not_eq H2 H3). - elim H;clear H;intros. - case H0;clear H0;intro. - left. - case (X.compare t0 t4);trivial;intros. - generalize (X.eq_sym H);intro. - generalize (X.eq_trans H2 e);intro. - elim (X.lt_not_eq H0 H3). - generalize (X.lt_trans H0 l);intro. - generalize (X.eq_sym H);intro. - elim (X.lt_not_eq H2 H3). - elim H0;clear H0;intros. - right. - split. - eauto. - eauto. - Qed. - - Lemma lt_not_eq : forall (x y:t),(lt x y)->~(eq x y). - unfold lt, eq;destruct x;destruct y;intro;intro. - elim H0;clear H0;intros. - case H. - intro. - apply (X.lt_not_eq H2 H0). - intro. - elim H2;clear H2;intros. - apply (Y.lt_not_eq H3 H1). - Qed. - - Definition compare : forall (x y:t),(Compare lt eq x y). - destruct x;destruct y. - case (X.compare t0 t2);intro. - apply LT. - left;trivial. - case (Y.compare t1 t3);intro. - apply LT. - right. - tauto. - apply EQ. - split;trivial. - apply GT. - right;auto. - apply GT. - left;trivial. - Defined. - - Hint Immediate eq_sym. - Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. -End OrderedPair. - -Module MessageSpi. - Inductive message : Set := - | MNam : nat -> message. - - Definition t := message. - - Fixpoint message_lt (m n:message) {struct m} : Prop := - match (m,n) with - | (MNam n1,MNam n2) => n1 < n2 - end. - - Module Ord <: OrderedType with Definition t := message with Definition eq := -@eq message. - Definition t := message. - Definition eq := @eq message. - Definition lt := message_lt. - - Lemma eq_refl : forall (x:t),eq x x. - unfold eq;auto. - Qed. - - Lemma eq_sym : forall (x y:t),(eq x y )->(eq y x). - unfold eq;auto. - Qed. - - Lemma eq_trans : forall (x y z:t),(eq x y)->(eq y z)->(eq x z). - unfold eq;auto;intros;congruence. - Qed. - - Lemma lt_trans : forall (x y z:t),(lt x y)->(lt y z)->(lt x z). - unfold lt. - induction x;destruct y;simpl;try tauto;destruct z;try tauto;intros. - omega. - Qed. - - Lemma lt_not_eq : forall (x y:t),(lt x y)->~(eq x y). - unfold eq;unfold lt. - induction x;destruct y;simpl;try tauto;intro;red;intro;try (discriminate -H0);injection H0;intros. - elim (lt_irrefl n);try omega. - Qed. - - Definition compare : forall (x y:t),(Compare lt eq x y). - unfold lt, eq. - induction x;destruct y;intros;try (apply LT;simpl;trivial;fail);try -(apply -GT;simpl;trivial;fail). - case (lt_eq_lt_dec n n0);intros;try (case s;clear s;intros). - apply LT;trivial. - apply EQ;trivial. - rewrite e;trivial. - apply GT;trivial. - Defined. - - Hint Immediate eq_sym. - Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. - End Ord. - - Theorem eq_dec : forall (m n:message),{m=n}+{~(m=n)}. - intros. - case (Ord.compare m n);intro;[right | left | right];try (red;intro). - elim (Ord.lt_not_eq m n);auto. - rewrite e;auto. - elim (Ord.lt_not_eq n m);auto. - Defined. -End MessageSpi. - -Module MessagePair := OrderedPair MessageSpi.Ord MessageSpi.Ord. - -Module Type Hedge := FSetInterface.S with Module E := MessagePair. - -Module A (H:Hedge). - Definition hedge := H.t. - - Definition message_relation := relation MessageSpi.message. - - Definition relation_of_hedge (h:hedge) (m n:MessageSpi.message) := H.In (m,n) -h. - - Inductive hedge_synthesis_relation (h:message_relation) : message_relation := - | SynInc : forall (m n:MessageSpi.message),(h m -n)->(hedge_synthesis_relation h m n). - - Fixpoint hedge_in_synthesis (h:hedge) (m:MessageSpi.message) -(n:MessageSpi.message) {struct m} : bool := - if H.mem (m,n) h - then true - else false. - - Definition hedge_synthesis_spec (h:hedge) := hedge_synthesis_relation -(relation_of_hedge h). - - Lemma hedge_in_synthesis_impl_hedge_synthesis_spec : forall (h:hedge),forall -(m n:MessageSpi.message),(hedge_in_synthesis h m n)=true->(hedge_synthesis_spec -h m n). - unfold hedge_synthesis_spec;unfold relation_of_hedge. - induction m;simpl;intro. - elim (Bool_elim_bool (H.mem (MessageSpi.MNam n,n0) h));intros. - apply SynInc;apply H.mem_2;trivial. - rewrite H in H0. (* !! possible here !! *) - discriminate H0. - Qed. -End A. - -Module B (H:Hedge). - Definition hedge := H.t. - - Definition message_relation := relation MessageSpi.t. - - Definition relation_of_hedge (h:hedge) (m n:MessageSpi.t) := H.In (m,n) h. - - Inductive hedge_synthesis_relation (h:message_relation) : message_relation := - | SynInc : forall (m n:MessageSpi.t),(h m n)->(hedge_synthesis_relation h m -n). - - Fixpoint hedge_in_synthesis (h:hedge) (m:MessageSpi.t) (n:MessageSpi.t) -{struct m} : bool := - if H.mem (m,n) h - then true - else false. - - Definition hedge_synthesis_spec (h:hedge) := hedge_synthesis_relation -(relation_of_hedge h). - - Lemma hedge_in_synthesis_impl_hedge_synthesis_spec : forall (h:hedge),forall -(m n:MessageSpi.t),(hedge_in_synthesis h m n)=true->(hedge_synthesis_spec h m -n). - unfold hedge_synthesis_spec;unfold relation_of_hedge. - induction m;simpl;intro. - elim (Bool_elim_bool (H.mem (MessageSpi.MNam n,n0) h));intros. - apply SynInc;apply H.mem_2;trivial. - - rewrite H in H0. (* !! impossible here !! *) - discriminate H0. - Qed. -End B. \ No newline at end of file diff --git a/test-suite/bugs/opened/shouldnotfail/1671.v b/test-suite/bugs/opened/shouldnotfail/1671.v deleted file mode 100644 index d95c2108..00000000 --- a/test-suite/bugs/opened/shouldnotfail/1671.v +++ /dev/null @@ -1,12 +0,0 @@ -(* Exemple soumis par Pierre Corbineau (bug #1671) *) - -CoInductive hdlist : unit -> Type := -| cons : hdlist tt -> hdlist tt. - -Variable P : forall bo, hdlist bo -> Prop. -Variable all : forall bo l, P bo l. - -Definition F (l:hdlist tt) : P tt l := -match l in hdlist u return P u l with -| cons (cons l') => all tt _ -end. diff --git a/test-suite/bugs/opened/shouldnotfail/1811.v b/test-suite/bugs/opened/shouldnotfail/1811.v deleted file mode 100644 index 037b7cb2..00000000 --- a/test-suite/bugs/opened/shouldnotfail/1811.v +++ /dev/null @@ -1,9 +0,0 @@ -Require Export Bool. - -Lemma neg2xor : forall b, xorb true b = negb b. -Proof. auto. Qed. - -Goal forall b1 b2, (negb b1 = b2) -> xorb true b1 = b2. -Proof. - intros b1 b2. - rewrite neg2xor. \ No newline at end of file diff --git a/test-suite/bugs/opened/shouldnotfail/2310.v b/test-suite/bugs/opened/shouldnotfail/2310.v deleted file mode 100644 index 8d1a5149..00000000 --- a/test-suite/bugs/opened/shouldnotfail/2310.v +++ /dev/null @@ -1,17 +0,0 @@ -(* Dependent higher-order hole in "refine" (simplified version) *) - -Set Implicit Arguments. - -Inductive Nest t := Cons : Nest (prod t t) -> Nest t. - -Definition cast A x y Heq P H := @eq_rect A x P H y Heq. - -Definition replace a (y:Nest (prod a a)) : a = a -> Nest a. - -(* This used to raise an anomaly Unknown Meta in 8.2 and 8.3beta. - It raises a regular error in 8.3 and almost succeeds with the new - proof engine: there are two solutions to a unification problem - (P:=\a.Nest (prod a a) and P:=\_.Nest (prod a a)) and refine should either - leave P as subgoal or choose itself one solution *) - -intros. refine (Cons (cast H _ y)). diff --git a/test-suite/bugs/opened/shouldnotfail/743.v b/test-suite/bugs/opened/shouldnotfail/743.v deleted file mode 100644 index f1eee6c1..00000000 --- a/test-suite/bugs/opened/shouldnotfail/743.v +++ /dev/null @@ -1,12 +0,0 @@ -Require Import Omega. - -Lemma foo : forall n m : Z, (n >= 0)%Z -> (n * m >= 0)%Z -> (n <= n + n * m)%Z. -Proof. - intros. omega. -Qed. - -Lemma foo' : forall n m : nat, n <= n + n * m. -Proof. - intros. omega. -Qed. - diff --git a/test-suite/check b/test-suite/check index 48a67449..3d14f6bc 100755 --- a/test-suite/check +++ b/test-suite/check @@ -2,10 +2,6 @@ MAKE="${MAKE:=make}" -if [ "$1" = -byte ]; then - export BEST=byte -fi - ${MAKE} clean > /dev/null 2>&1 ${MAKE} all > /dev/null 2>&1 cat summary.log diff --git a/test-suite/complexity/injection.v b/test-suite/complexity/injection.v index 335996c2..08f489d7 100644 --- a/test-suite/complexity/injection.v +++ b/test-suite/complexity/injection.v @@ -72,14 +72,14 @@ Definition own_join (a b c: own) : Prop := match a , b , c with | NO , _ , _ => b=c | _ , NO , _ => a=c - | VAL' sa _ , VAL' sb _, VAL' sc _ => Share.j.(join) sa sb sc - | LK sa pa ha fa, LK sb pb hb fb, LK sc pc hc fc => + | @VAL' sa _, @VAL' sb _, @VAL' sc _ => Share.j.(join) sa sb sc + | @LK sa pa ha fa, @LK sb pb hb fb, @LK sc pc hc fc => Share.j.(join) sa sb sc /\ Share.j.(join) ha hb hc /\ fa=fc /\ fb=fc - | CT sa pa , CT sb pb, CT sc pc => Share.j.(join) sa sb sc - | FUN sa pa fa, FUN sb pb fb, FUN sc pc fc => + | @CT sa pa , @CT sb pb, @CT sc pc => Share.j.(join) sa sb sc + | @FUN sa pa fa, @FUN sb pb fb, @FUN sc pc fc => Share.j.(join) sa sb sc /\ fa=fc /\ fb=fc | _ , _ , _ => False end. diff --git a/test-suite/coqchk/univ.v b/test-suite/coqchk/univ.v new file mode 100644 index 00000000..84a4009d --- /dev/null +++ b/test-suite/coqchk/univ.v @@ -0,0 +1,35 @@ + +Inductive equivalent P Q := Equivalent (P_to_Q : P -> Q) (Q_to_P : Q -> P). + +Inductive equal T (x : T) : T -> Type := Equal : equal T x x. + +(* Arithmetic *) + +Inductive natural := Zero | Add_1_to (n : natural). + +Fixpoint add (m n : natural) : natural := + match m with Zero => n | Add_1_to m_minus_1 => add m_minus_1 (Add_1_to n) end. + +Definition double (n : natural) : natural := add n n. + +Inductive odd (n : natural) := + Odd (half : natural) + (n_odd : equal natural n (Add_1_to (double half))). + +Inductive less_than (m n : natural) := + LessThan (diff : natural) + (m_lt_n : equal natural n (Add_1_to (add m diff))). + +(* Finite subsets *) + +Definition injective_in T R (D : T -> Type) (f : T -> R) := + forall x y, D x -> D y -> equal R (f x) (f y) -> equal T x y. + +Inductive in_image T R (D : T -> Type) (f : T -> R) (a : R) := + InImage (x : T) (x_in_D : D x) (a_is_fx : equal R a (f x)). + +Inductive finite_of_order T (D : T -> Type) (n : natural) := + FiniteOfOrder (rank : T -> natural) + (rank_injective : injective_in T natural D rank) + (rank_onto : + forall i, equivalent (less_than i n) (in_image T natural D rank i)). diff --git a/test-suite/failure/Case1.v b/test-suite/failure/Case1.v index df11ed38..6e76d42d 100644 --- a/test-suite/failure/Case1.v +++ b/test-suite/failure/Case1.v @@ -1,4 +1,4 @@ -Type match 0 with +Fail Type match 0 with | x => 0 | O => 1 end. diff --git a/test-suite/failure/Case10.v b/test-suite/failure/Case10.v index 43cc1e34..661d98cd 100644 --- a/test-suite/failure/Case10.v +++ b/test-suite/failure/Case10.v @@ -1,3 +1,3 @@ -Type (fun x : nat => match x return nat with +Fail Type (fun x : nat => match x return nat with | S x as b => S b end). diff --git a/test-suite/failure/Case11.v b/test-suite/failure/Case11.v index e76d0609..675f79e6 100644 --- a/test-suite/failure/Case11.v +++ b/test-suite/failure/Case11.v @@ -1,3 +1,3 @@ -Type (fun x : nat => match x return nat with +Fail Type (fun x : nat => match x return nat with | S x as b => S b x end). diff --git a/test-suite/failure/Case12.v b/test-suite/failure/Case12.v index cf6c2026..4a77f139 100644 --- a/test-suite/failure/Case12.v +++ b/test-suite/failure/Case12.v @@ -1,5 +1,5 @@ -Type +Fail Type (fun x : nat => match x return nat with | S x as b => match x with diff --git a/test-suite/failure/Case13.v b/test-suite/failure/Case13.v index 994dfd20..5c0aa3e1 100644 --- a/test-suite/failure/Case13.v +++ b/test-suite/failure/Case13.v @@ -1,4 +1,4 @@ -Type +Fail Type (fun x : nat => match x return nat with | S x as b => match x with diff --git a/test-suite/failure/Case14.v b/test-suite/failure/Case14.v index ba0c51a1..29cae764 100644 --- a/test-suite/failure/Case14.v +++ b/test-suite/failure/Case14.v @@ -3,7 +3,7 @@ Inductive List (A : Set) : Set := | Cons : A -> List A -> List A. Definition NIL := Nil nat. -Type match Nil nat return (List nat) with +Fail Type match Nil nat return (List nat) with | NIL => NIL | _ => NIL end. diff --git a/test-suite/failure/Case15.v b/test-suite/failure/Case15.v index 18faaf5c..ec08e614 100644 --- a/test-suite/failure/Case15.v +++ b/test-suite/failure/Case15.v @@ -1,6 +1,6 @@ (* Non exhaustive pattern-matching *) -Check +Fail Check (fun x => match x, x with | O, S (S y) => true diff --git a/test-suite/failure/Case16.v b/test-suite/failure/Case16.v index 3739adae..df15a428 100644 --- a/test-suite/failure/Case16.v +++ b/test-suite/failure/Case16.v @@ -1,6 +1,6 @@ (* Check for redundant clauses *) -Check +Fail Check (fun x => match x, x with | O, S (S y) => true diff --git a/test-suite/failure/Case2.v b/test-suite/failure/Case2.v index 7d81ee81..f8c95b1e 100644 --- a/test-suite/failure/Case2.v +++ b/test-suite/failure/Case2.v @@ -4,7 +4,7 @@ Inductive IFExpr : Set := | Fa : IFExpr | IfE : IFExpr -> IFExpr -> IFExpr -> IFExpr. -Type +Fail Type (fun F : IFExpr => match F return Prop with | IfE (Var _) H I => True diff --git a/test-suite/failure/Case3.v b/test-suite/failure/Case3.v index ca450d5b..eaafd41f 100644 --- a/test-suite/failure/Case3.v +++ b/test-suite/failure/Case3.v @@ -2,7 +2,7 @@ Inductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. -Type +Fail Type (fun l : List nat => match l return nat with | Nil nat => 0 diff --git a/test-suite/failure/Case4.v b/test-suite/failure/Case4.v index de63c3f7..4da7ef0c 100644 --- a/test-suite/failure/Case4.v +++ b/test-suite/failure/Case4.v @@ -1,5 +1,5 @@ -Definition Berry (x y z : bool) := +Fail Definition Berry (x y z : bool) := match x, y, z with | true, false, _ => 0 | false, _, true => 1 diff --git a/test-suite/failure/Case5.v b/test-suite/failure/Case5.v index 494443f1..70e5b988 100644 --- a/test-suite/failure/Case5.v +++ b/test-suite/failure/Case5.v @@ -2,6 +2,6 @@ Inductive MS : Set := | X : MS -> MS | Y : MS -> MS. -Type (fun p : MS => match p return nat with +Fail Type (fun p : MS => match p return nat with | X x => 0 end). diff --git a/test-suite/failure/Case6.v b/test-suite/failure/Case6.v index fb8659bf..cb7b7de0 100644 --- a/test-suite/failure/Case6.v +++ b/test-suite/failure/Case6.v @@ -2,7 +2,7 @@ Inductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. -Type (match Nil nat return List nat with +Fail Type (match Nil nat return List nat with | NIL => NIL | (CONS _ _) => NIL end). diff --git a/test-suite/failure/Case7.v b/test-suite/failure/Case7.v index 64453481..e1fd7df0 100644 --- a/test-suite/failure/Case7.v +++ b/test-suite/failure/Case7.v @@ -9,7 +9,7 @@ Definition length1 (n : nat) (l : listn n) := | _ => 0 end. -Type +Fail Type (fun (n : nat) (l : listn n) => match n return nat with | O => 0 diff --git a/test-suite/failure/Case8.v b/test-suite/failure/Case8.v index feae29a7..035629fe 100644 --- a/test-suite/failure/Case8.v +++ b/test-suite/failure/Case8.v @@ -2,7 +2,7 @@ Inductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. -Type match Nil nat return nat with +Fail Type match Nil nat return nat with | b => b | Cons _ _ _ as d => d end. diff --git a/test-suite/failure/Case9.v b/test-suite/failure/Case9.v index d63c4940..642f85d7 100644 --- a/test-suite/failure/Case9.v +++ b/test-suite/failure/Case9.v @@ -1,8 +1,8 @@ Parameter compare : forall n m : nat, {n < m} + {n = m} + {n > m}. -Type +Fail Type match compare 0 0 return nat with - (* k 0 - (* k=i *) | left _ _ _ => 0 - (* k>i *) | right _ _ _ => 0 + (* k 0 + (* k=i *) | left _ _ => 0 + (* k>i *) | right _ _ => 0 end. diff --git a/test-suite/failure/ClearBody.v b/test-suite/failure/ClearBody.v index 609d5b3b..e321e59f 100644 --- a/test-suite/failure/ClearBody.v +++ b/test-suite/failure/ClearBody.v @@ -5,4 +5,4 @@ Goal True. set (n := 0) in *. set (I := refl_equal 0) in *. change (n = 0) in (type of I). -clearbody n. +Fail clearbody n. diff --git a/test-suite/failure/ImportedCoercion.v b/test-suite/failure/ImportedCoercion.v index 0a69b851..1cac69f4 100644 --- a/test-suite/failure/ImportedCoercion.v +++ b/test-suite/failure/ImportedCoercion.v @@ -4,4 +4,4 @@ Require Import make_local. (* Local coercion must not be used *) -Check (0 = true). +Fail Check (0 = true). diff --git a/test-suite/failure/Notations.v b/test-suite/failure/Notations.v index 074e176a..83459de3 100644 --- a/test-suite/failure/Notations.v +++ b/test-suite/failure/Notations.v @@ -3,5 +3,5 @@ Notation "! A" := (forall i:nat, A) (at level 60). (* Should fail: no dynamic capture *) -Check ! (i=i). +Fail Check ! (i=i). diff --git a/test-suite/failure/Reordering.v b/test-suite/failure/Reordering.v index 7b36d1c3..e79b2073 100644 --- a/test-suite/failure/Reordering.v +++ b/test-suite/failure/Reordering.v @@ -2,4 +2,4 @@ Goal forall (A:Set) (x:A) (A':=A), True. intros. -change ((fun (_:A') => Set) x) in (type of A). +Fail change ((fun (_:A') => Set) x) in (type of A). diff --git a/test-suite/failure/Sections.v b/test-suite/failure/Sections.v index 9b3b35c1..928e214f 100644 --- a/test-suite/failure/Sections.v +++ b/test-suite/failure/Sections.v @@ -1,4 +1,4 @@ Module A. Section B. -End A. -End A. +Fail End A. +(*End A.*) diff --git a/test-suite/failure/Tauto.v b/test-suite/failure/Tauto.v index 11b40951..749db000 100644 --- a/test-suite/failure/Tauto.v +++ b/test-suite/failure/Tauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* forall x y : nat, x = y \/ x <> y. Proof. - tauto. + Fail tauto. diff --git a/test-suite/failure/Uminus.v b/test-suite/failure/Uminus.v index 3c3bf375..cc31c7ae 100644 --- a/test-suite/failure/Uminus.v +++ b/test-suite/failure/Uminus.v @@ -1,62 +1,21 @@ (* Check that the encoding of system U- fails *) -Inductive prop : Prop := down : Prop -> prop. - -Definition up (p:prop) : Prop := let (A) := p in A. - -Lemma p2p1 : forall A:Prop, up (down A) -> A. -Proof. -exact (fun A x => x). -Qed. +Require Hurkens. -Lemma p2p2 : forall A:Prop, A -> up (down A). -Proof. -exact (fun A x => x). -Qed. - -(** Hurkens' paradox *) - -Definition V := forall A:Prop, ((A -> prop) -> A -> prop) -> A -> prop. -Definition U := V -> prop. -Definition sb (z:V) : V := fun A r a => r (z A r) a. -Definition le (i:U -> prop) (x:U) : prop := - x (fun A r a => i (fun v => sb v A r a)). -Definition induct (i:U -> prop) : Prop := - forall x:U, up (le i x) -> up (i x). -Definition WF : U := fun z => down (induct (z U le)). -Definition I (x:U) : Prop := - (forall i:U -> prop, up (le i x) -> up (i (fun v => sb v U le x))) -> False. +Inductive prop : Prop := down : Prop -> prop. -Lemma Omega : forall i:U -> prop, induct i -> up (i WF). -Proof. -intros i y. -apply y. -unfold le, WF, induct. -intros x H0. -apply y. -exact H0. -Qed. +(* Coq should reject the following access of a Prop buried inside + a prop. *) -Lemma lemma1 : induct (fun u => down (I u)). -Proof. -unfold induct. -intros x p. -intro q. -apply (q (fun u => down (I u)) p). -intro i. -apply q with (i := fun y => i (fun v:V => sb v U le y)). -Qed. +Fail Definition up (p:prop) : Prop := let (A) := p in A. -Lemma lemma2 : (forall i:U -> prop, induct i -> up (i WF)) -> False. -Proof. -intro x. -apply (x (fun u => down (I u)) lemma1). -intros i H0. -apply (x (fun y => i (fun v => sb v U le y))). -apply H0. -Qed. +(* Otherwise, we would have a proof of False via Hurkens' paradox *) -Theorem paradox : False. -Proof. -exact (lemma2 Omega). -Qed. +Fail Definition paradox : False := + Hurkens.NoRetractFromSmallPropositionToProp.paradox + prop + down + up + (fun (A:Prop) (x:up (down A)) => (x:A)) + (fun (A:Prop) (x:A) => (x:up (down A))) + False. diff --git a/test-suite/failure/autorewritein.v b/test-suite/failure/autorewritein.v index dc17742a..191e035b 100644 --- a/test-suite/failure/autorewritein.v +++ b/test-suite/failure/autorewritein.v @@ -9,7 +9,7 @@ Hint Rewrite Ack0 Ack1 Ack2 : base0. Lemma ResAck2 : forall H:(Ack 2 2 = 7 -> False), H=H -> False. Proof. intros. - autorewrite with base0 in * using try (apply H1;reflexivity). + Fail autorewrite with base0 in * using try (apply H1;reflexivity). diff --git a/test-suite/failure/cases.v b/test-suite/failure/cases.v index 18faaf5c..ec08e614 100644 --- a/test-suite/failure/cases.v +++ b/test-suite/failure/cases.v @@ -1,6 +1,6 @@ (* Non exhaustive pattern-matching *) -Check +Fail Check (fun x => match x, x with | O, S (S y) => true diff --git a/test-suite/failure/check.v b/test-suite/failure/check.v index 649fdd2d..a148ebe8 100644 --- a/test-suite/failure/check.v +++ b/test-suite/failure/check.v @@ -1,3 +1,3 @@ Implicit Arguments eq [A]. -Check (bool = true). +Fail Check (bool = true). diff --git a/test-suite/failure/circular_subtyping.v b/test-suite/failure/circular_subtyping.v new file mode 100644 index 00000000..ceccd460 --- /dev/null +++ b/test-suite/failure/circular_subtyping.v @@ -0,0 +1,10 @@ +(* subtyping verification in presence of pseudo-circularity*) +Module Type S. End S. +Module Type T. Declare Module M:S. End T. +Module N:S. End N. +Module NN <: T. Module M:=N. End NN. + +Fail Module P <: T with Module M:=NN := NN. + +Module F (X:S) (Y:T with Module M:=X). End F. +Fail Module G := F N N. \ No newline at end of file diff --git a/test-suite/failure/circular_subtyping1.v b/test-suite/failure/circular_subtyping1.v deleted file mode 100644 index 0b3a8688..00000000 --- a/test-suite/failure/circular_subtyping1.v +++ /dev/null @@ -1,7 +0,0 @@ -(* subtyping verification in presence of pseudo-circularity*) -Module Type S. End S. -Module Type T. Declare Module M:S. End T. - -Module N:S. End N. -Module NN <: T. Module M:=N. End NN. -Module P <: T with Module M:=NN := NN. diff --git a/test-suite/failure/circular_subtyping2.v b/test-suite/failure/circular_subtyping2.v deleted file mode 100644 index 3bacdc65..00000000 --- a/test-suite/failure/circular_subtyping2.v +++ /dev/null @@ -1,8 +0,0 @@ -(*subtyping verification in presence of pseudo-circularity at functor application *) -Module Type S. End S. -Module Type T. Declare Module M:S. End T. -Module N:S. End N. - -Module F (X:S) (Y:T with Module M:=X). End F. - -Module G := F N N. \ No newline at end of file diff --git a/test-suite/failure/clash_cons.v b/test-suite/failure/clash_cons.v index 17e56763..8e34ffbd 100644 --- a/test-suite/failure/clash_cons.v +++ b/test-suite/failure/clash_cons.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* nat. fix f 1. intro n; apply f; assumption. -Guarded. +Fail Guarded. diff --git a/test-suite/failure/fixpoint3.v b/test-suite/failure/fixpoint3.v index 42f06916..7d1d3ee6 100644 --- a/test-suite/failure/fixpoint3.v +++ b/test-suite/failure/fixpoint3.v @@ -6,7 +6,7 @@ Inductive I : Prop := Definition i0 := C (fun _ x => x). -Definition Paradox : False := +Fail Definition Paradox : False := (fix ni i : False := match i with | C f => ni (f _ i) diff --git a/test-suite/failure/fixpoint4.v b/test-suite/failure/fixpoint4.v index fd956373..bf6133f1 100644 --- a/test-suite/failure/fixpoint4.v +++ b/test-suite/failure/fixpoint4.v @@ -8,7 +8,7 @@ Inductive IMP : Prop := Definition i0 := (LIMP (fun _ => CIMP (fun _ x => x))). -Definition Paradox : False := +Fail Definition Paradox : False := (fix F y o {struct o} : False := match y with | tt => fun f => diff --git a/test-suite/failure/guard-cofix.v b/test-suite/failure/guard-cofix.v new file mode 100644 index 00000000..64faa0ce --- /dev/null +++ b/test-suite/failure/guard-cofix.v @@ -0,0 +1,43 @@ +(* This script shows, in two different ways, the inconsistency of the +propositional extensionality axiom with the guard condition for cofixpoints. It +is the dual of the problem on fixpoints (cf subterm.v, subterm2.v, +subterm3.v). Posted on Coq-club by Maxime Dénès (02/26/2014). *) + +(* First example *) + +CoInductive CoFalse : Prop := CF : CoFalse -> False -> CoFalse. + +CoInductive Pandora : Prop := C : CoFalse -> Pandora. + +Axiom prop_ext : forall P Q : Prop, (P<->Q) -> P = Q. + +Lemma foo : Pandora = CoFalse. +apply prop_ext. +constructor. +intro x; destruct x; assumption. +exact C. +Qed. + +Fail CoFixpoint loop : CoFalse := +match foo in (_ = T) return T with eq_refl => C loop end. + +Fail Definition ff : False := match loop with CF _ t => t end. + +(* Second example *) + +Inductive omega := Omega : omega -> omega. + +Lemma H : omega = CoFalse. +Proof. +apply prop_ext; constructor. + induction 1; assumption. +destruct 1; destruct H0. +Qed. + +Fail CoFixpoint loop' : CoFalse := + match H in _ = T return T with + eq_refl => + Omega match eq_sym H in _ = T return T with eq_refl => loop' end + end. + +Fail Definition ff' : False := match loop' with CF _ t => t end. \ No newline at end of file diff --git a/test-suite/failure/guard.v b/test-suite/failure/guard.v index 78a0782a..b3a0a335 100644 --- a/test-suite/failure/guard.v +++ b/test-suite/failure/guard.v @@ -1,16 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* nat) := f1 in let _ := 0 in let _ := 0 in diff --git a/test-suite/failure/illtype1.v b/test-suite/failure/illtype1.v index 5781c96b..7e4c5ac5 100644 --- a/test-suite/failure/illtype1.v +++ b/test-suite/failure/illtype1.v @@ -1,8 +1,8 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* B -> prod A B. +Fail Check (fun (A:Type) (B:Prop) => (prod A B : Prop)). +Fail Check (fun (A:Prop) (B:Type) => (prod A B : Prop)). + +(* Check that the nested inductive types positivity check avoids recursively + non uniform parameters (at least if these parameters break positivity) *) + +Inductive t (A:Type) : Type := c : t (A -> A) -> t A. +Fail Inductive u : Type := d : u | e : t u -> u. + +(* This used to succeed in versions 8.1 to 8.3 *) + +Require Import Logic. +Require Hurkens. +Definition Ti := Type. +Inductive prod2 (X Y:Ti) := pair2 : X -> Y -> prod2 X Y. +Fail Definition B : Prop := let F := prod2 True in F Prop. (* Aie! *) +(*Definition p2b (P:Prop) : B := pair2 True Prop I P. +Definition b2p (b:B) : Prop := match b with pair2 _ P => P end. +Lemma L1 : forall A : Prop, b2p (p2b A) -> A. +Proof (fun A x => x). +Lemma L2 : forall A : Prop, A -> b2p (p2b A). +Proof (fun A x => x). +Check Hurkens.paradox B p2b b2p L1 L2.*) + diff --git a/test-suite/failure/inductive1.v b/test-suite/failure/inductive1.v deleted file mode 100644 index 3b57d919..00000000 --- a/test-suite/failure/inductive1.v +++ /dev/null @@ -1,4 +0,0 @@ -(* A check that sort-polymorphic product is not set too low *) - -Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. -Check (fun (A:Type) (B:Prop) => (prod A B : Prop)). diff --git a/test-suite/failure/inductive2.v b/test-suite/failure/inductive2.v deleted file mode 100644 index b77474be..00000000 --- a/test-suite/failure/inductive2.v +++ /dev/null @@ -1,4 +0,0 @@ -(* A check that sort-polymorphic product is not set too low *) - -Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. -Check (fun (A:Prop) (B:Type) => (prod A B : Prop)). diff --git a/test-suite/failure/inductive3.v b/test-suite/failure/inductive3.v deleted file mode 100644 index cf035edf..00000000 --- a/test-suite/failure/inductive3.v +++ /dev/null @@ -1,5 +0,0 @@ -(* Check that the nested inductive types positivity check avoids recursively - non uniform parameters (at least if these parameters break positivity) *) - -Inductive t (A:Type) : Type := c : t (A -> A) -> t A. -Inductive u : Type := d : u | e : t u -> u. diff --git a/test-suite/failure/inductive4.v b/test-suite/failure/inductive4.v deleted file mode 100644 index 6ba36fd2..00000000 --- a/test-suite/failure/inductive4.v +++ /dev/null @@ -1,15 +0,0 @@ -(* This used to succeed in versions 8.1 to 8.3 *) - -Require Import Logic. -Require Hurkens. -Definition Ti := Type. -Inductive prod (X Y:Ti) := pair : X -> Y -> prod X Y. -Definition B : Prop := let F := prod True in F Prop. (* Aie! *) -Definition p2b (P:Prop) : B := pair True Prop I P. -Definition b2p (b:B) : Prop := match b with pair _ P => P end. -Lemma L1 : forall A : Prop, b2p (p2b A) -> A. -Proof (fun A x => x). -Lemma L2 : forall A : Prop, A -> b2p (p2b A). -Proof (fun A x => x). -Check Hurkens.paradox B p2b b2p L1 L2. - diff --git a/test-suite/failure/ltac1.v b/test-suite/failure/ltac1.v index 7b496a75..eef16525 100644 --- a/test-suite/failure/ltac1.v +++ b/test-suite/failure/ltac1.v @@ -4,4 +4,4 @@ Ltac X := match goal with end. Goal True -> True -> True. intros. -X. +Fail X. diff --git a/test-suite/failure/ltac2.v b/test-suite/failure/ltac2.v index 14436e58..d66fb680 100644 --- a/test-suite/failure/ltac2.v +++ b/test-suite/failure/ltac2.v @@ -1,6 +1,6 @@ (* Check that Match arguments are forbidden *) Ltac E x := apply x. Goal True -> True. -E ltac:(match goal with +Fail E ltac:(match goal with | |- _ => intro H end). diff --git a/test-suite/failure/ltac4.v b/test-suite/failure/ltac4.v index 41471275..5b0396d1 100644 --- a/test-suite/failure/ltac4.v +++ b/test-suite/failure/ltac4.v @@ -1,5 +1,6 @@ (* Check static globalisation of tactic names *) (* Proposed by Benjamin (mars 2002) *) Goal forall n : nat, n = n. -induction n; try REflexivity. +induction n. +Fail try REflexivity. diff --git a/test-suite/failure/pattern.v b/test-suite/failure/pattern.v index a24beaa2..216eb254 100644 --- a/test-suite/failure/pattern.v +++ b/test-suite/failure/pattern.v @@ -6,4 +6,4 @@ Variable P : forall m : nat, m = n -> Prop. Goal forall p : n = n, P n p. intro. -pattern n, p. +Fail pattern n, p. diff --git a/test-suite/failure/positivity.v b/test-suite/failure/positivity.v index 1c1080d1..d44bccdf 100644 --- a/test-suite/failure/positivity.v +++ b/test-suite/failure/positivity.v @@ -1,9 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* nat) -> t. diff --git a/test-suite/failure/proofirrelevance.v b/test-suite/failure/proofirrelevance.v index 93e159e8..b62f9b68 100644 --- a/test-suite/failure/proofirrelevance.v +++ b/test-suite/failure/proofirrelevance.v @@ -6,6 +6,9 @@ Inductive bool_in_prop : Type := hide : bool -> bool_in_prop with bool : Type := true : bool | false : bool. Lemma not_proof_irrelevance : ~ forall (P:Prop) (p p':P), p=p'. -intro H; pose proof (H bool_in_prop (hide true) (hide false)); discriminate. -Qed. +intro H. +Fail pose proof (H bool_in_prop (hide true) (hide false)). +Abort. +(*discriminate. +Qed.*) diff --git a/test-suite/failure/prop-set-proof-irrelevance.v b/test-suite/failure/prop-set-proof-irrelevance.v index ad494108..fee33432 100644 --- a/test-suite/failure/prop-set-proof-irrelevance.v +++ b/test-suite/failure/prop-set-proof-irrelevance.v @@ -1,12 +1,12 @@ Require Import ProofIrrelevance. Lemma proof_irrelevance_set : forall (P : Set) (p1 p2 : P), p1 = p2. - exact proof_irrelevance. -Qed. + Fail exact proof_irrelevance. +(*Qed. Lemma paradox : False. assert (H : 0 <> 1) by discriminate. apply H. Fail apply proof_irrelevance. (* inlined version is rejected *) apply proof_irrelevance_set. -Qed. +Qed.*) diff --git a/test-suite/failure/redef.v b/test-suite/failure/redef.v index ef6d01d0..e5db8176 100644 --- a/test-suite/failure/redef.v +++ b/test-suite/failure/redef.v @@ -1,9 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop) (x:T1) , f x -> Type. intros until x. - rewrite H in x. + Fail rewrite H in x. diff --git a/test-suite/failure/rewrite_in_hyp.v b/test-suite/failure/rewrite_in_hyp.v index 613d707c..1eef0fa0 100644 --- a/test-suite/failure/rewrite_in_hyp.v +++ b/test-suite/failure/rewrite_in_hyp.v @@ -1,3 +1,3 @@ Goal forall (T1 T2 : Type) (f:T1 -> Prop) (x:T1) (H:T1=T2), f x -> 0=1. intros T1 T2 f x H fx. - rewrite H in x. + Fail rewrite H in x. diff --git a/test-suite/failure/rewrite_in_hyp2.v b/test-suite/failure/rewrite_in_hyp2.v index 1533966e..112a856e 100644 --- a/test-suite/failure/rewrite_in_hyp2.v +++ b/test-suite/failure/rewrite_in_hyp2.v @@ -5,4 +5,4 @@ Goal forall b, S b = O -> (fun a => 0 = (S a)) b -> True. intros b H H0. - rewrite H in H0. + Fail rewrite H in H0. diff --git a/test-suite/failure/search.v b/test-suite/failure/search.v index 9c35ecfb..a6e6bc48 100644 --- a/test-suite/failure/search.v +++ b/test-suite/failure/search.v @@ -1,9 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop. +Variable up : Prop -> Type1. + +Hypothesis back : forall A, up (down A) -> A. + +Hypothesis forth : forall A, A -> up (down A). + +Hypothesis backforth : forall (A:Type) (P:A->Type) (a:A), + P (back A (forth A a)) -> P a. + +Hypothesis backforth_r : forall (A:Type) (P:A->Type) (a:A), + P a -> P (back A (forth A a)). + +(** Proof *) + +Definition V : Type1 := forall A:Prop, ((up A -> Prop) -> up A -> Prop) -> up A -> Prop. +Definition U : Type1 := V -> Prop. + +Definition sb (z:V) : V := fun A r a => r (z A r) a. +Definition le (i:U -> Prop) (x:U) : Prop := x (fun A r a => i (fun v => sb v A r a)). +Definition le' (i:up (down U) -> Prop) (x:up (down U)) : Prop := le (fun a:U => i (forth _ a)) (back _ x). +Definition induct (i:U -> Prop) : Type1 := forall x:U, up (le i x) -> up (i x). +Definition WF : U := fun z => down (induct (fun a => z (down U) le' (forth _ a))). +Definition I (x:U) : Prop := + (forall i:U -> Prop, up (le i x) -> up (i (fun v => sb v (down U) le' (forth _ x)))) -> False. + +Lemma Omega : forall i:U -> Prop, induct i -> up (i WF). +Proof. +intros i y. +apply y. +unfold le, WF, induct. +apply forth. +intros x H0. +apply y. +unfold sb, le', le. +compute. +apply backforth_r. +exact H0. +Qed. + +Lemma lemma1 : induct (fun u => down (I u)). +Proof. +unfold induct. +intros x p. +apply forth. +intro q. +generalize (q (fun u => down (I u)) p). +intro r. +apply back in r. +apply r. +intros i j. +unfold le, sb, le', le in j |-. +apply backforth in j. +specialize q with (i := fun y => i (fun v:V => sb v (down U) le' (forth _ y))). +apply q. +exact j. +Qed. + +Lemma lemma2 : (forall i:U -> Prop, induct i -> up (i WF)) -> False. +Proof. +intro x. +generalize (x (fun u => down (I u)) lemma1). +intro r; apply back in r. +apply r. +intros i H0. +apply (x (fun y => i (fun v => sb v (down U) le' (forth _ y)))). +unfold le, WF in H0. +apply back in H0. +exact H0. +Qed. + +Theorem paradox : False. +Proof. +exact (lemma2 Omega). +Qed. + +End Hurkens. + +(* Alright, now we use a DeBruijn index off-by-1 error to build a type +satisfying the hypotheses of the paradox. What is tricky is that the pretyper is +not affected by the bug (only the kernel is). Even worse, since our goal is to +bypass the elimination restriction for types in Prop, we have to devise a way to +feed the kernel with an illegal pattern matching without going through the +pattern matching compiler (which calls the pretyper). The trick is to use the +record machinery, which defines projections, checking if the kernel accepts +it. *) + +Definition informative (x : bool) := + match x with + | true => Type + | false => Prop + end. + +Definition depsort (T : Type) (x : bool) : informative x := + match x with + | true => T + | false => True + end. + +(* The let-bound parameters in the record below trigger the error *) + +Record Box (ff := false) (tt := true) (T : Type) : Prop := + wrap {prop : depsort T tt}. + +Definition down (x : Type) : Prop := Box x. +Definition up (x : Prop) : Type := x. + +Fail Definition back A : up (down A) -> A := prop A. + +(* If the projection has been defined, the following script derives a proof of +false. + +Definition forth A : A -> up (down A) := wrap A. + +Definition backforth (A:Type) (P:A->Type) (a:A) : + P (back A (forth A a)) -> P a := fun H => H. + +Definition backforth_r (A:Type) (P:A->Type) (a:A) : + P a -> P (back A (forth A a)) := fun H => H. + +(* Everything set up, we just check that we built the right context for the +paradox to apply. *) + +Theorem pandora : False. +apply (paradox down up back forth backforth backforth_r). +Qed. + +Print Assumptions pandora. + +*) \ No newline at end of file diff --git a/test-suite/failure/subterm.v b/test-suite/failure/subterm.v new file mode 100644 index 00000000..3798bc48 --- /dev/null +++ b/test-suite/failure/subterm.v @@ -0,0 +1,45 @@ +Module Foo. + Inductive True2:Prop:= I2: (False->True2)->True2. + + Axiom Heq: (False->True2)=True2. + + Fail Fixpoint con (x:True2) :False := + match x with + I2 f => con (match Heq with @eq_refl _ _ => f end) + end. +End Foo. + +Require Import ClassicalFacts. + +Inductive True1 : Prop := I1 : True1 +with True2 : Prop := I2 : True1 -> True2. + +Section func_unit_discr. + +Hypothesis Heq : True1 = True2. + +Fail Fixpoint contradiction (u : True2) : False := +contradiction ( + match u with + | I2 Tr => + match Heq in (_ = T) return T with + | eq_refl => Tr + end + end). + +End func_unit_discr. + +Require Import Vectors.VectorDef. + +About caseS. +About tl. +Open Scope vector_scope. +Local Notation "[]" := (@nil _). +Local Notation "h :: t" := (@cons _ h _ t) (at level 60, right associativity). +Definition is_nil {A n} (v : t A n) : bool := match v with [] => true | _ => false end. + +Fixpoint id {A n} (v : t A n) : t A n := + match v in t _ n' return t A n' with + | (h :: t) as v' => h :: id (tl v') + |_ => [] + end. diff --git a/test-suite/failure/subterm2.v b/test-suite/failure/subterm2.v new file mode 100644 index 00000000..a420a4d7 --- /dev/null +++ b/test-suite/failure/subterm2.v @@ -0,0 +1,48 @@ +(* An example showing that prop-extensionality is incompatible with + powerful extensions of the guard condition. + Unlike the example in guard2, it is not exploiting the fact that + the elimination of False always produces a subterm. + + Example due to Cristobal Camarero on Coq-Club. + Adapted to nested types by Bruno Barras. + *) + +Axiom prop_ext: forall P Q, (P<->Q)->P=Q. + +Module Unboxed. + +Inductive True2:Prop:= I2: (False->True2)->True2. + +Theorem Heq: (False->True2)=True2. +Proof. +apply prop_ext. split. +- intros. constructor. exact H. +- intros. exact H. +Qed. + +Fail Fixpoint con (x:True2) :False := +match x with +I2 f => con (match Heq in _=T return T with eq_refl => f end) +end. + +End Unboxed. + +(* This boxed example shows that it is not enough to just require + that the return type of the match on Heq is an inductive type + *) +Module Boxed. + +Inductive box (T:Type) := Box (_:T). +Definition unbox {T} (b:box T) : T := let (x) := b in x. + +Inductive True2:Prop:= I2: box(False->True2)->True2. + +Definition Heq: (False->True2) <-> True2 := + conj (fun f => I2 (Box _ f)) (fun x _ => x). + +Fail Fixpoint con (x:True2) :False := +match x with +I2 f => con (unbox(match prop_ext _ _ Heq in _=T return box T with eq_refl => f end)) +end. + +End Boxed. diff --git a/test-suite/failure/subterm3.v b/test-suite/failure/subterm3.v new file mode 100644 index 00000000..2cef6357 --- /dev/null +++ b/test-suite/failure/subterm3.v @@ -0,0 +1,29 @@ +(* An example showing that prop-extensionality is incompatible with + powerful extensions of the guard condition. + This is a variation on the example in subterm2, exploiting + missing typing constraints in the commutative cut subterm rule + (subterm2 is using the same flaw but for the match rule). + + Example due to Cristóbal Camarero on Coq-Club. + *) + +Axiom prop_ext: forall P Q, (P <-> Q) -> P=Q. + +Inductive True2 : Prop := I3 : (False -> True2) -> True2. + +Theorem T3T: True2 = True. +Proof. +apply prop_ext; split; auto. +intros; constructor; apply False_rect. +Qed. + +Theorem T3F_FT3F : (True2 -> False) = ((False -> True2) -> False). +Proof. +rewrite T3T. +apply prop_ext; split; auto. +Qed. + +Fail Fixpoint loop (x : True2) : False := +match x with +I3 f => (match T3F_FT3F in _=T return T with eq_refl=> loop end) f +end. diff --git a/test-suite/failure/subtyping.v b/test-suite/failure/subtyping.v index 127da851..e48c6689 100644 --- a/test-suite/failure/subtyping.v +++ b/test-suite/failure/subtyping.v @@ -18,4 +18,4 @@ Module TT : T. | L0 | L1 : (A -> Prop) -> L. -End TT. +Fail End TT. diff --git a/test-suite/failure/subtyping2.v b/test-suite/failure/subtyping2.v index 48fc2fff..8b2dc1dc 100644 --- a/test-suite/failure/subtyping2.v +++ b/test-suite/failure/subtyping2.v @@ -242,4 +242,4 @@ Defined. with the constraint j >= i in the paradox. *) - Definition Paradox : False := Burali_Forti A0 i0' inj. + Fail Definition Paradox : False := Burali_Forti A0 i0' inj. diff --git a/test-suite/failure/univ_include.v b/test-suite/failure/univ_include.v index 56f04f9d..28a3263d 100644 --- a/test-suite/failure/univ_include.v +++ b/test-suite/failure/univ_include.v @@ -23,8 +23,8 @@ Module Mt. Definition t := T. End Mt. -Module P := G Mt. (* should yield Universe inconsistency *) +Fail Module P := G Mt. (* should yield Universe inconsistency *) (* ... otherwise the following command will show that T has type T! *) -Eval cbv delta [P.elt Mt.t] in P.elt. +(* Eval cbv delta [P.elt Mt.t] in P.elt. *) diff --git a/test-suite/failure/universes-buraliforti-redef.v b/test-suite/failure/universes-buraliforti-redef.v index a8b5b975..e0168158 100644 --- a/test-suite/failure/universes-buraliforti-redef.v +++ b/test-suite/failure/universes-buraliforti-redef.v @@ -230,17 +230,17 @@ End Burali_Forti_Paradox. intros. change match i0 X1 R1, i0 X2 R2 with - | i1 x1 r1, i1 x2 r2 => exists f : _, morphism x1 r1 x2 r2 f + | i1 _ _ x1 r1, i1 _ _ x2 r2 => exists f : _, morphism x1 r1 x2 r2 f end. case H; simpl. exists (fun x : X1 => x). red; trivial. Defined. -(* The following command raises 'Error: Universe Inconsistency'. +(* The following command should raise 'Error: Universe Inconsistency'. To allow large elimination of A0, i0 must not be a large constructor. Hence, the constraint Type_j' < Type_i' is added, which is incompatible with the constraint j >= i in the paradox. *) - Definition Paradox : False := Burali_Forti A0 i0 inj. + Fail Definition Paradox : False := Burali_Forti A0 i0 inj. diff --git a/test-suite/failure/universes-buraliforti.v b/test-suite/failure/universes-buraliforti.v index 7b62a0c5..dba1a794 100644 --- a/test-suite/failure/universes-buraliforti.v +++ b/test-suite/failure/universes-buraliforti.v @@ -234,4 +234,4 @@ Defined. with the constraint j >= i in the paradox. *) - Definition Paradox : False := Burali_Forti A0 i0 inj. + Fail Definition Paradox : False := Burali_Forti A0 i0 inj. diff --git a/test-suite/failure/universes-sections1.v b/test-suite/failure/universes-sections1.v index 6cd04349..3f8e4446 100644 --- a/test-suite/failure/universes-sections1.v +++ b/test-suite/failure/universes-sections1.v @@ -5,4 +5,4 @@ Section A. Definition Type1 : Type2 := Type. End A. -Definition Inconsistency : Type1 := Type2. +Fail Definition Inconsistency : Type1 := Type2. diff --git a/test-suite/failure/universes-sections2.v b/test-suite/failure/universes-sections2.v index 98fdbc0d..34b2a11d 100644 --- a/test-suite/failure/universes-sections2.v +++ b/test-suite/failure/universes-sections2.v @@ -7,4 +7,4 @@ Section A. Definition Type1' := Type1. End A. -Definition Inconsistency : Type1' := Type2. +Fail Definition Inconsistency : Type1' := Type2. diff --git a/test-suite/failure/universes.v b/test-suite/failure/universes.v index 938c29b8..d708b01f 100644 --- a/test-suite/failure/universes.v +++ b/test-suite/failure/universes.v @@ -1,3 +1,3 @@ Definition Type2 := Type. Definition Type1 : Type2 := Type. -Definition Inconsistency : Type1 := Type2. +Fail Definition Inconsistency : Type1 := Type2. diff --git a/test-suite/failure/universes3.v b/test-suite/failure/universes3.v index 8fb414d5..ee7a63c8 100644 --- a/test-suite/failure/universes3.v +++ b/test-suite/failure/universes3.v @@ -17,7 +17,7 @@ Inductive I (B:Type (*6*)) := C : B -> impl Prop (I B). (* We cannot enforce Type1 < Type(6) while we already have Type(6) <= Type(7) < Type3 < Type1 *) -Definition J := I Type1. +Fail Definition J := I Type1. (* Open question: should the type of an inductive be the max of the types of the _arguments_ of its constructors (here B and Prop, diff --git a/test-suite/ide/blocking-futures.fake b/test-suite/ide/blocking-futures.fake new file mode 100644 index 00000000..b63f09bc --- /dev/null +++ b/test-suite/ide/blocking-futures.fake @@ -0,0 +1,16 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# Extraction will force the future computation, assert it is blocking +# Example courtesy of Jonathan (jonikelee) +# +ADD { Require Import List. } +ADD { Import ListNotations. } +ADD { Definition myrev{A}(l : list A) : {rl : list A | rl = rev l}. } +ADD { Proof. } +ADD { induction l. } +ADD { eexists; reflexivity. } +ADD { cbn; destruct IHl as [rl' H]; rewrite <-H; eexists; reflexivity. } +ADD { Qed. } +ADD { Extraction myrev. } +GOALS diff --git a/test-suite/ide/undo001.fake b/test-suite/ide/undo001.fake index bbaea7e7..55263615 100644 --- a/test-suite/ide/undo001.fake +++ b/test-suite/ide/undo001.fake @@ -3,8 +3,8 @@ # # Simple backtrack by 1 between two global definitions # -INTERP Definition foo := 0. -INTERP Definition bar := 1. -REWIND 1 -INTERPRAW Check foo. -INTERPRAW Fail Check bar. +ADD here { Definition foo := 0. } +ADD { Definition bar := 1. } +EDIT_AT here +QUERY { Check foo. } +QUERY { Fail Check bar. } diff --git a/test-suite/ide/undo002.fake b/test-suite/ide/undo002.fake index b855b6ea..5284c5d3 100644 --- a/test-suite/ide/undo002.fake +++ b/test-suite/ide/undo002.fake @@ -3,8 +3,8 @@ # # Simple backtrack by 2 before two global definitions # -INTERP Definition foo := 0. -INTERP Definition bar := 1. -REWIND 2 -INTERPRAW Fail Check foo. -INTERPRAW Fail Check bar. +ADD { Definition foo := 0. } +ADD { Definition bar := 1. } +EDIT_AT initial +QUERY { Fail Check foo. } +QUERY { Fail Check bar. } diff --git a/test-suite/ide/undo003.fake b/test-suite/ide/undo003.fake index 4c72e8dc..90757627 100644 --- a/test-suite/ide/undo003.fake +++ b/test-suite/ide/undo003.fake @@ -3,6 +3,6 @@ # # Simple backtrack by 0 should be a no-op # -INTERP Definition foo := 0. -REWIND 0 -INTERPRAW Check foo. +ADD here { Definition foo := 0. } +EDIT_AT here +QUERY { Check foo. } diff --git a/test-suite/ide/undo004.fake b/test-suite/ide/undo004.fake index c2ddfb8c..9029b03e 100644 --- a/test-suite/ide/undo004.fake +++ b/test-suite/ide/undo004.fake @@ -3,12 +3,12 @@ # # Undoing arbitrary commands, as first step # -INTERP Theorem a : O=O. -INTERP Ltac f x := x. -REWIND 1 +ADD here { Theorem a : O=O. } +ADD { Ltac f x := x. } +EDIT_AT here # -INTERP Ltac f x := x. +ADD { Ltac f x := x. } # <\replay> -INTERP assert True by trivial. -INTERP trivial. -INTERP Qed. +ADD { assert True by trivial. } +ADD { trivial. } +ADD { Qed. } diff --git a/test-suite/ide/undo005.fake b/test-suite/ide/undo005.fake index 525b9f2a..7e31c0b0 100644 --- a/test-suite/ide/undo005.fake +++ b/test-suite/ide/undo005.fake @@ -3,13 +3,13 @@ # # Undoing arbitrary commands, as non-first step # -INTERP Theorem b : O=O. -INTERP assert True by trivial. -INTERP Ltac g x := x. +ADD { Theorem b : O=O. } +ADD here { assert True by trivial. } +ADD { Ltac g x := x. } # -REWIND 1 +EDIT_AT here # <\replay> -INTERP Ltac g x := x. -INTERP assert True by trivial. -INTERP trivial. -INTERP Qed. +ADD { Ltac g x := x. } +ADD { assert True by trivial. } +ADD { trivial. } +ADD { Qed. } diff --git a/test-suite/ide/undo006.fake b/test-suite/ide/undo006.fake index ed88bef5..cdfdee1b 100644 --- a/test-suite/ide/undo006.fake +++ b/test-suite/ide/undo006.fake @@ -4,11 +4,11 @@ # Undoing declarations, as first step # Was bugged in 8.1 # -INTERP Theorem c : O=O. -INTERP Inductive T : Type := I. -REWIND 1 +ADD here { Theorem c : O=O. } +ADD { Inductive T : Type := I. } +EDIT_AT here # -INTERP Inductive T : Type := I. +ADD { Inductive T : Type := I. } # <\replay> -INTERP trivial. -INTERP Qed. +ADD { trivial. } +ADD { Qed. } diff --git a/test-suite/ide/undo007.fake b/test-suite/ide/undo007.fake deleted file mode 100644 index 87c06dbb..00000000 --- a/test-suite/ide/undo007.fake +++ /dev/null @@ -1,17 +0,0 @@ -# Script simulating a dialog between coqide and coqtop -ideslave -# Run it via fake_ide -# -# Undoing declarations, as first step -# new in 8.2 -# -INTERP Theorem d : O=O. -INTERP Definition e := O. -INTERP Definition f := O. -REWIND 1 -# -INTERP Definition f := O. -# <\replay> -INTERP assert True by trivial. -INTERP trivial. -INTERP Qed. -INTERPRAW Check e. diff --git a/test-suite/ide/undo008.fake b/test-suite/ide/undo008.fake index 1c46c1e8..72cab7a3 100644 --- a/test-suite/ide/undo008.fake +++ b/test-suite/ide/undo008.fake @@ -4,15 +4,15 @@ # Undoing declarations, as non-first step # new in 8.2 # -INTERP Theorem h : O=O. -INTERP assert True by trivial. -INTERP Definition i := O. -INTERP Definition j := O. -REWIND 1 +ADD { Theorem h : O=O. } +ADD { assert True by trivial. } +ADD here { Definition i := O. } +ADD { Definition j := O. } +EDIT_AT here # -INTERP Definition j := O. +ADD { Definition j := O. } # <\replay> -INTERP assert True by trivial. -INTERP trivial. -INTERP Qed. -INTERPRAW Check i. +ADD { assert True by trivial. } +ADD { trivial. } +ADD { Qed. } +QUERY { Check i. } diff --git a/test-suite/ide/undo009.fake b/test-suite/ide/undo009.fake index 47c77d23..76f400ef 100644 --- a/test-suite/ide/undo009.fake +++ b/test-suite/ide/undo009.fake @@ -4,17 +4,18 @@ # Undoing declarations, interleaved with proof steps # new in 8.2 *) # -INTERP Theorem k : O=O. -INTERP assert True by trivial. -INTERP Definition l := O. -INTERP assert True by trivial. -INTERP Definition m := O. -REWIND 3 +ADD { Theorem k : O=O. } +ADD here { assert True by trivial. } +ADD { Definition l := O. } +ADD { assert True by trivial. } +ADD { Definition m := O. } +QUERY { Show. } +EDIT_AT here # -INTERP Definition l := O. -INTERP assert True by trivial. -INTERP Definition m := O. +ADD { Definition l := O. } +ADD { assert True by trivial. } +ADD { Definition m := O. } # <\replay> -INTERP assert True by trivial. -INTERP trivial. -INTERP Qed. +ADD { assert True by trivial. } +ADD { trivial. } +ADD { Qed. } diff --git a/test-suite/ide/undo010.fake b/test-suite/ide/undo010.fake index 4fe9df98..524416c3 100644 --- a/test-suite/ide/undo010.fake +++ b/test-suite/ide/undo010.fake @@ -4,25 +4,25 @@ # Undoing declarations, interleaved with proof steps and commands *) # new in 8.2 *) # -INTERP Theorem n : O=O. -INTERP assert True by trivial. -INTERP Definition o := O. -INTERP Ltac h x := x. -INTERP assert True by trivial. -INTERP Focus. -INTERP Definition p := O. -REWIND 1 -REWIND 1 -REWIND 1 -REWIND 1 -REWIND 1 +ADD { Theorem n : O=O. } +ADD s2 { assert True by trivial. } +ADD s3 { Definition o := O. } +ADD s4 { Ltac h x := x. } +ADD s5 { assert True by trivial. } +ADD s6 { Focus. } +ADD { Definition p := O. } +EDIT_AT s6 +EDIT_AT s5 +EDIT_AT s4 +EDIT_AT s3 +EDIT_AT s2 # -INTERP Definition o := O. -INTERP Ltac h x := x. -INTERP assert True by trivial. -INTERP Focus. -INTERP Definition p := O. +ADD { Definition o := O. } +ADD { Ltac h x := x. } +ADD { assert True by trivial. } +ADD { Focus. } +ADD { Definition p := O. } # -INTERP assert True by trivial. -INTERP trivial. -INTERP Qed. +ADD { assert True by trivial. } +ADD { trivial. } +ADD { Qed. } diff --git a/test-suite/ide/undo011.fake b/test-suite/ide/undo011.fake index cc85a764..0be439b2 100644 --- a/test-suite/ide/undo011.fake +++ b/test-suite/ide/undo011.fake @@ -4,29 +4,31 @@ # Bug 2082 # Broken due to proof engine rewriting # -INTERP Variable A : Prop. -INTERP Variable B : Prop. -INTERP Axiom OR : A \/ B. -INTERP Lemma MyLemma2 : True. -INTERP proof. -INTERP per cases of (A \/ B) by OR. -INTERP suppose A. -INTERP then (1 = 1). -INTERP then H1 : thesis. -INTERP thus thesis by H1. -INTERP suppose B. -REWIND 1 +ADD { Variable A : Prop. } +ADD { Variable B : Prop. } +ADD { Axiom OR : A \/ B. } +ADD { Lemma MyLemma2 : True. } +ADD { proof. } +ADD { per cases of (A \/ B) by OR. } +ADD { suppose A. } +ADD { then (1 = 1). } +ADD there { then H1 : thesis. } +ADD here { thus thesis by H1. } +ADD { suppose B. } +QUERY { Show. } +EDIT_AT here # -INTERP suppose B. +ADD { suppose B. } # -REWIND 2 +EDIT_AT there # -INTERP thus thesis by H1. -INTERP suppose B. +ADD { thus thesis by H1. } +ADD { suppose B. } # -INTERP then (1 = 1). -INTERP then H2 : thesis. -INTERP thus thesis by H2. -INTERP end cases. -INTERP end proof. -INTERP Qed. +QUERY { Show. } +ADD { then (1 = 1). } +ADD { then H2 : thesis. } +ADD { thus thesis by H2. } +ADD { end cases. } +ADD { end proof. } +ADD { Qed. } diff --git a/test-suite/ide/undo012.fake b/test-suite/ide/undo012.fake index f9b29ca1..b3d1c6d5 100644 --- a/test-suite/ide/undo012.fake +++ b/test-suite/ide/undo012.fake @@ -2,25 +2,25 @@ # Run it via fake_ide # # Test backtracking in presence of nested proofs -# First, undoing the whole # -INTERP Lemma aa : True -> True /\ True. -INTERP intro H. -INTERP split. -INTERP Lemma bb : False -> False. -INTERP intro H. -INTERP apply H. -INTERP Qed. -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. -INTERP Qed. -INTERP apply H. -INTERP Qed. -REWIND 1 -# We should now be just before aa, without opened proofs -INTERPRAW Fail idtac. -INTERPRAW Fail Check aa. -INTERPRAW Fail Check bb. -INTERPRAW Fail Check cc. +ADD { Lemma aa : True -> True /\ True. } +ADD { intro H. } +ADD { split. } +ADD { Lemma bb : False -> False. } +ADD { intro H. } +ADD { apply H. } +ADD { Qed. } +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD { intro H. } +ADD { destruct H. } +ADD { Qed. } +QUERY { Show. } +ADD here { apply H. } +ADD { Qed. } +EDIT_AT here +# We should now be just before the Qed. +QUERY { Fail Check aa. } +QUERY { Check bb. } +QUERY { Check cc. } +ADD { Qed. } diff --git a/test-suite/ide/undo013.fake b/test-suite/ide/undo013.fake index 3b1c61e6..f44156aa 100644 --- a/test-suite/ide/undo013.fake +++ b/test-suite/ide/undo013.fake @@ -2,30 +2,26 @@ # Run it via fake_ide # # Test backtracking in presence of nested proofs -# Second, trigger the full undo of an inner proof +# Second, trigger the undo of an inner proof # -INTERP Lemma aa : True -> True /\ True. -INTERP intro H. -INTERP split. -INTERP Lemma bb : False -> False. -INTERP intro H. -INTERP apply H. -INTERP Qed. -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. -INTERP Qed. -INTERP apply H. -REWIND 2 -# We should now be just before "Lemma cc" +ADD { Lemma aa : True -> True /\ True. } +ADD { intro H. } +ADD { split. } +ADD { Lemma bb : False -> False. } +ADD { intro H. } +ADD { apply H. } +ADD { Qed. } +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD { intro H. } +ADD here { destruct H. } +ADD { Qed. } +ADD { apply H. } +EDIT_AT here # -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. -INTERP Qed. -INTERP apply H. +ADD { Qed. } +ADD { apply H. } # -INTERP Qed. -INTERPRAW Fail idtac. -INTERPRAW Check (aa,bb,cc). +ADD { Qed. } +QUERY { Fail idtac. } +QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo014.fake b/test-suite/ide/undo014.fake index 5224b504..6d58b061 100644 --- a/test-suite/ide/undo014.fake +++ b/test-suite/ide/undo014.fake @@ -4,23 +4,23 @@ # Test backtracking in presence of nested proofs # Third, undo inside an inner proof # -INTERP Lemma aa : True -> True /\ True. -INTERP intro H. -INTERP split. -INTERP Lemma bb : False -> False. -INTERP intro H. -INTERP apply H. -INTERP Qed. -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. -REWIND 1 +ADD { Lemma aa : True -> True /\ True. } +ADD { intro H. } +ADD { split. } +ADD { Lemma bb : False -> False. } +ADD { intro H. } +ADD { apply H. } +ADD { Qed. } +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD here { intro H. } +ADD { destruct H. } +EDIT_AT here # -INTERP destruct H. +ADD { destruct H. } # -INTERP Qed. -INTERP apply H. -INTERP Qed. -INTERPRAW Fail idtac. -INTERPRAW Check (aa,bb,cc). +ADD { Qed. } +ADD { apply H. } +ADD { Qed. } +QUERY { Fail idtac. } +QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo015.fake b/test-suite/ide/undo015.fake index 32e46ec9..ac17985a 100644 --- a/test-suite/ide/undo015.fake +++ b/test-suite/ide/undo015.fake @@ -4,26 +4,26 @@ # Test backtracking in presence of nested proofs # Fourth, undo from an inner proof to a above proof # -INTERP Lemma aa : True -> True /\ True. -INTERP intro H. -INTERP split. -INTERP Lemma bb : False -> False. -INTERP intro H. -INTERP apply H. -INTERP Qed. -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. -REWIND 4 +ADD { Lemma aa : True -> True /\ True. } +ADD { intro H. } +ADD { split. } +ADD { Lemma bb : False -> False. } +ADD { intro H. } +ADD { apply H. } +ADD here { Qed. } +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD { intro H. } +ADD { destruct H. } +EDIT_AT here # -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD { intro H. } +ADD { destruct H. } # -INTERP Qed. -INTERP apply H. -INTERP Qed. -INTERPRAW Fail idtac. -INTERPRAW Check (aa,bb,cc). +ADD { Qed. } +ADD { apply H. } +ADD { Qed. } +QUERY { Fail idtac. } +QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo016.fake b/test-suite/ide/undo016.fake index 2a6e512c..bdb81ecd 100644 --- a/test-suite/ide/undo016.fake +++ b/test-suite/ide/undo016.fake @@ -4,31 +4,28 @@ # Test backtracking in presence of nested proofs # Fifth, undo from an inner proof to a previous inner proof # -INTERP Lemma aa : True -> True /\ True. -INTERP intro H. -INTERP split. -INTERP Lemma bb : False -> False. -INTERP intro H. -INTERP apply H. -INTERP Qed. -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. -REWIND 6 -# We should be just before "Lemma bb" +ADD { Lemma aa : True -> True /\ True. } +ADD { intro H. } +ADD { split. } +ADD { Lemma bb : False -> False. } +ADD here { intro H. } +ADD { apply H. } +ADD { Qed. } +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD { intro H. } +ADD { destruct H. } +EDIT_AT here # -INTERP Lemma bb : False -> False. -INTERP intro H. -INTERP apply H. -INTERP Qed. -INTERP apply H. -INTERP Lemma cc : False -> True. -INTERP intro H. -INTERP destruct H. +ADD { apply H. } +ADD { Qed. } +ADD { apply H. } +ADD { Lemma cc : False -> True. } +ADD { intro H. } +ADD { destruct H. } # -INTERP Qed. -INTERP apply H. -INTERP Qed. -INTERPRAW Fail idtac. -INTERPRAW Check (aa,bb,cc). +ADD { Qed. } +ADD { apply H. } +ADD { Qed. } +QUERY { Fail idtac. } +QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo017.fake b/test-suite/ide/undo017.fake index 232360e9..37423dc7 100644 --- a/test-suite/ide/undo017.fake +++ b/test-suite/ide/undo017.fake @@ -3,11 +3,11 @@ # # bug #2569 : Undoing inside modules # -INTERP Module M. -INTERP Definition x := 0. -INTERP End M. -REWIND 1 +ADD { Module M. } +ADD here { Definition x := 0. } +ADD { End M. } +EDIT_AT here # -INTERP End M. +ADD { End M. } # -INTERPRAW Check M.x. +QUERY { Check M.x. } diff --git a/test-suite/ide/undo018.fake b/test-suite/ide/undo018.fake index ef0945ab..11091bfa 100644 --- a/test-suite/ide/undo018.fake +++ b/test-suite/ide/undo018.fake @@ -3,11 +3,11 @@ # # bug #2569 : Undoing inside section # -INTERP Section M. -INTERP Definition x := 0. -INTERP End M. -REWIND 1 +ADD { Section M. } +ADD here { Definition x := 0. } +ADD { End M. } +EDIT_AT here # -INTERP End M. +ADD { End M. } # -INTERPRAW Check x. +QUERY { Check x. } diff --git a/test-suite/ide/undo019.fake b/test-suite/ide/undo019.fake index 70e70d7e..5df49ebb 100644 --- a/test-suite/ide/undo019.fake +++ b/test-suite/ide/undo019.fake @@ -3,12 +3,12 @@ # # bug #2569 : Undoing a focused subproof # -INTERP Goal True. -INTERP { -INTERP exact I. -INTERP } -REWIND 1 +ADD { Goal True. } +ADD { \{ } +ADD here { exact I. } +ADD { \} } +EDIT_AT here # -INTERP } +ADD { \} } # -INTERP Qed. +ADD { Qed. } diff --git a/test-suite/ide/undo020.fake b/test-suite/ide/undo020.fake new file mode 100644 index 00000000..2adde908 --- /dev/null +++ b/test-suite/ide/undo020.fake @@ -0,0 +1,27 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# focusing a broken proof and fixing it + +# first proof +ADD { Lemma a : True. } +ADD { Proof using. } +ADD here { idtac. } +ADD { exact Ix. } +ADD { Qed. } +# second proof +ADD { Lemma b : False. } +ADD { Proof using. } +ADD { admit. } +ADD last { Qed. } +# We join and expect some proof to fail +WAIT +# Going back to the error +EDIT_AT here +# Fixing the proof +ADD { exact I. } +ADD { Qed. } +# we are back at the end +ASSERT TIP last +QUERY { Check a. } +QUERY { Check b. } diff --git a/test-suite/ide/undo021.fake b/test-suite/ide/undo021.fake new file mode 100644 index 00000000..0d83ad25 --- /dev/null +++ b/test-suite/ide/undo021.fake @@ -0,0 +1,29 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# jumping between broken proofs + +# first proof +ADD { Lemma a : True. } +ADD { Proof using. } +ADD here { idtac. } +ADD { exact Ix. } +ADD { Qed. } +# second proof +ADD { Lemma b : True. } +ADD here2 { Proof using. } +ADD { exact Ix. } +ADD { Qed. } +# We wait all slaves and expect both proofs to fail +WAIT +# Going back to the error +EDIT_AT here2 +# this is not implemented yet, all after here is erased +EDIT_AT here +# Fixing the proof +ADD { exact I. } +ADD last { Qed. } +ASSERT TIP last +# we are back at the end +QUERY { Check a. } +QUERY { Fail Check b. } diff --git a/test-suite/ide/undo022.fake b/test-suite/ide/undo022.fake new file mode 100644 index 00000000..51d8d106 --- /dev/null +++ b/test-suite/ide/undo022.fake @@ -0,0 +1,41 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# jumping between broken proofs + interp error while fixing. +# the error should note make the GUI unfocus the currently focused proof. + +# first proof +ADD { Lemma a : True /\ True. } +ADD { Proof using. } +ADD here { split. } +ADD { exact Ix. } # first error +ADD { exact Ix. } # second error +ADD { Qed. } +# second proof +ADD { Lemma b : True. } +ADD { Proof using. } +ADD { exact I. } +ADD last { Qed. } +# We wait all slaves and expect both proofs to fail +WAIT +# Going back to the error +EDIT_AT here +# Fixing the proof +ADD fix { exact I. } +# showing the goals +GOALS +# re adding the wrong step +ADD { exact Ix. } +# showing the goals (failure) and retracting to the safe state suggested by Coq +FAILGOALS +# we assert we jumped back to the state immediately before the last (erroneous) +# one +ASSERT TIP fix +# finish off the proof +ADD { exact I. } +ADD { Qed. } +# here we unfocus, hence we jump back to the end of the document +ASSERT TIP last +# we are back at the end +QUERY { Check a. } +QUERY { Check b. } diff --git a/test-suite/ideal-features/Apply.v b/test-suite/ideal-features/Apply.v index a4bbfba8..ed46eb22 100644 --- a/test-suite/ideal-features/Apply.v +++ b/test-suite/ideal-features/Apply.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 1 + | S m => match m with + | O => 1 + | S o => fib o + fib m end end. + +Ltac sleep n := + try (cut (fib n = S (fib n)); reflexivity). + +(* Tune that depending on your PC *) +Let time := 18. + + +(* Beginning of demo *) + +Section Demo. + +Variable i : True. + +Lemma a : True. +Proof using i. + sleep time. + idtac. + sleep time. + (* Error, jump back to fix it, then Qed again *) + exact (i i). +Qed. + +Lemma b : True. +Proof using i. + sleep time. + idtac. + sleep time. + (* Here we use "a" *) + exact a. +Qed. + +Lemma work_here : True /\ True. +Proof using i. +(* Jump directly here, Coq reacts immediately *) +split. + exact b. (* We can use the lemmas above *) +exact a. +Qed. + +End Demo. \ No newline at end of file diff --git a/test-suite/interactive/ParalITP_smallproofs.v b/test-suite/interactive/ParalITP_smallproofs.v new file mode 100755 index 00000000..0d75d52a --- /dev/null +++ b/test-suite/interactive/ParalITP_smallproofs.v @@ -0,0 +1,3041 @@ +(* This program is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Lesser General Public License *) +(* as published by the Free Software Foundation; either version 2.1 *) +(* 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 Lesser General Public *) +(* License along with this program; if not, write to the Free *) +(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) +(* 02110-1301 USA *) + + +(** This file includes random facts about Integers (and natural numbers) which are not found in the standard library. Some of the lemma here are not used in the QArith developement but are rather useful. +*) + +Require Export ZArith. +Require Export ZArithRing. + +Tactic Notation "ElimCompare" constr(c) constr(d) := elim_compare c d. + +Ltac Flip := + apply Zgt_lt || apply Zlt_gt || apply Zle_ge || apply Zge_le; assumption. + +Ltac Falsum := + try intro; apply False_ind; + repeat + match goal with + | id1:(~ ?X1) |- ?X2 => + (apply id1; assumption || reflexivity) || clear id1 + end. + + +Ltac Step_l a := + match goal with + | |- (?X1 < ?X2)%Z => replace X1 with a; [ idtac | try ring ] + end. + +Ltac Step_r a := + match goal with + | |- (?X1 < ?X2)%Z => replace X2 with a; [ idtac | try ring ] + end. + +Ltac CaseEq formula := + generalize (refl_equal formula); pattern formula at -1 in |- *; + case formula. + + +Lemma pair_1 : forall (A B : Set) (H : A * B), H = pair (fst H) (snd H). +Proof. + intros. + case H. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma pair_2 : + forall (A B : Set) (H1 H2 : A * B), + fst H1 = fst H2 -> snd H1 = snd H2 -> H1 = H2. +Proof. + intros A B H1 H2. + case H1. + case H2. + simpl in |- *. + intros. + rewrite H. + rewrite H0. + reflexivity. +Qed. + + +Section projection. + Variable A : Set. + Variable P : A -> Prop. + + Definition projP1 (H : sig P) := let (x, h) := H in x. + Definition projP2 (H : sig P) := + let (x, h) as H return (P (projP1 H)) := H in h. +End projection. + + +(*###########################################################################*) +(* Declaring some realtions on natural numbers for stepl and stepr tactics. *) +(*###########################################################################*) + +Lemma le_stepl: forall x y z, le x y -> x=z -> le z y. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma le_stepr: forall x y z, le x y -> y=z -> le x z. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma lt_stepl: forall x y z, lt x y -> x=z -> lt z y. +Proof. + intros x y z H_lt H_eq; subst z; trivial. +Qed. + +Lemma lt_stepr: forall x y z, lt x y -> y=z -> lt x z. +Proof. + intros x y z H_lt H_eq; subst z; trivial. +Qed. + +Lemma neq_stepl:forall (x y z:nat), x<>y -> x=z -> z<>y. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + +Lemma neq_stepr:forall (x y z:nat), x<>y -> y=z -> x<>z. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + + +Declare Left Step le_stepl. +Declare Right Step le_stepr. +Declare Left Step lt_stepl. +Declare Right Step lt_stepr. +Declare Left Step neq_stepl. +Declare Right Step neq_stepr. + +(*###########################################################################*) +(** Some random facts about natural numbers, positive numbers and integers *) +(*###########################################################################*) + + +Lemma not_O_S : forall n : nat, n <> 0 -> {p : nat | n = S p}. +Proof. + intros [| np] Hn; [ exists 0; apply False_ind; apply Hn | exists np ]; + reflexivity. +Qed. + + +Lemma lt_minus_neq : forall m n : nat, m < n -> n - m <> 0. +Proof. + intros. + omega. +Qed. + +Lemma lt_minus_eq_0 : forall m n : nat, m < n -> m - n = 0. +Proof. + intros. + omega. +Qed. + +Lemma le_plus_Sn_1_SSn : forall n : nat, S n + 1 <= S (S n). +Proof. + intros. + omega. +Qed. + +Lemma le_plus_O_l : forall p q : nat, p + q <= 0 -> p = 0. +Proof. + intros; omega. +Qed. + +Lemma le_plus_O_r : forall p q : nat, p + q <= 0 -> q = 0. +Proof. + intros; omega. +Qed. + +Lemma minus_pred : forall m n : nat, 0 < n -> pred m - pred n = m - n. +Proof. + intros. + omega. +Qed. + + +(*###########################################################################*) +(* Declaring some realtions on integers for stepl and stepr tactics. *) +(*###########################################################################*) + +Lemma Zle_stepl: forall x y z, (x<=y)%Z -> x=z -> (z<=y)%Z. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma Zle_stepr: forall x y z, (x<=y)%Z -> y=z -> (x<=z)%Z. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma Zlt_stepl: forall x y z, (x x=z -> (z y=z -> (xy)%Z -> x=z -> (z<>y)%Z. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + +Lemma Zneq_stepr:forall (x y z:Z), (x<>y)%Z -> y=z -> (x<>z)%Z. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + +Declare Left Step Zle_stepl. +Declare Right Step Zle_stepr. +Declare Left Step Zlt_stepl. +Declare Right Step Zlt_stepr. +Declare Left Step Zneq_stepl. +Declare Right Step Zneq_stepr. + + +(*###########################################################################*) +(** Informative case analysis *) +(*###########################################################################*) + +Lemma Zlt_cotrans : + forall x y : Z, (x < y)%Z -> forall z : Z, {(x < z)%Z} + {(z < y)%Z}. +Proof. + intros. + case (Z_lt_ge_dec x z). + intro. + left. + assumption. + intro. + right. + apply Zle_lt_trans with (m := x). + apply Zge_le. + assumption. + assumption. +Qed. + +Lemma Zlt_cotrans_pos : + forall x y : Z, (0 < x + y)%Z -> {(0 < x)%Z} + {(0 < y)%Z}. +Proof. + intros. + case (Zlt_cotrans 0 (x + y) H x). + intro. + left. + assumption. + intro. + right. + apply Zplus_lt_reg_l with (p := x). + rewrite Zplus_0_r. + assumption. +Qed. + + +Lemma Zlt_cotrans_neg : + forall x y : Z, (x + y < 0)%Z -> {(x < 0)%Z} + {(y < 0)%Z}. +Proof. + intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy; + [ right; apply Zplus_lt_reg_l with (p := x); rewrite Zplus_0_r | left ]; + assumption. +Qed. + + + +Lemma not_Zeq_inf : forall x y : Z, x <> y -> {(x < y)%Z} + {(y < x)%Z}. +Proof. + intros. + case Z_lt_ge_dec with x y. + intro. + left. + assumption. + intro H0. + generalize (Zge_le _ _ H0). + intro. + case (Z_le_lt_eq_dec _ _ H1). + intro. + right. + assumption. + intro. + apply False_rec. + apply H. + symmetry in |- *. + assumption. +Qed. + +Lemma Z_dec : forall x y : Z, {(x < y)%Z} + {(x > y)%Z} + {x = y}. +Proof. + intros. + case (Z_lt_ge_dec x y). + intro H. + left. + left. + assumption. + intro H. + generalize (Zge_le _ _ H). + intro H0. + case (Z_le_lt_eq_dec y x H0). + intro H1. + left. + right. + apply Zlt_gt. + assumption. + intro. + right. + symmetry in |- *. + assumption. +Qed. + + +Lemma Z_dec' : forall x y : Z, {(x < y)%Z} + {(y < x)%Z} + {x = y}. +Proof. + intros x y. + case (Z_eq_dec x y); intro H; + [ right; assumption | left; apply (not_Zeq_inf _ _ H) ]. +Qed. + +Lemma Z_lt_le_dec : forall x y : Z, {(x < y)%Z} + {(y <= x)%Z}. +Proof. + intros. + case (Z_lt_ge_dec x y). + intro. + left. + assumption. + intro. + right. + apply Zge_le. + assumption. +Qed. + +Lemma Z_le_lt_dec : forall x y : Z, {(x <= y)%Z} + {(y < x)%Z}. +Proof. + intros; case (Z_lt_le_dec y x); [ right | left ]; assumption. +Qed. + +Lemma Z_lt_lt_S_eq_dec : + forall x y : Z, (x < y)%Z -> {(x + 1 < y)%Z} + {(x + 1)%Z = y}. +Proof. + intros. + generalize (Zlt_le_succ _ _ H). + unfold Zsucc in |- *. + apply Z_le_lt_eq_dec. +Qed. + +Lemma quadro_leq_inf : + forall a b c d : Z, + {(c <= a)%Z /\ (d <= b)%Z} + {~ ((c <= a)%Z /\ (d <= b)%Z)}. +Proof. + intros. + case (Z_lt_le_dec a c). + intro z. + right. + intro. + elim H. + intros. + generalize z. + apply Zle_not_lt. + assumption. + intro. + case (Z_lt_le_dec b d). + intro z0. + right. + intro. + elim H. + intros. + generalize z0. + apply Zle_not_lt. + assumption. + intro. + left. + split. + assumption. + assumption. +Qed. + +(*###########################################################################*) +(** General auxiliary lemmata *) +(*###########################################################################*) + +Lemma Zminus_eq : forall x y : Z, (x - y)%Z = 0%Z -> x = y. +Proof. + intros. + apply Zplus_reg_l with (- y)%Z. + rewrite Zplus_opp_l. + unfold Zminus in H. + rewrite Zplus_comm. + assumption. +Qed. + +Lemma Zlt_minus : forall a b : Z, (b < a)%Z -> (0 < a - b)%Z. +Proof. + intros a b. + intros. + apply Zplus_lt_reg_l with b. + unfold Zminus in |- *. + rewrite (Zplus_comm a). + rewrite (Zplus_assoc b (- b)). + rewrite Zplus_opp_r. + simpl in |- *. + rewrite <- Zplus_0_r_reverse. + assumption. +Qed. + + +Lemma Zle_minus : forall a b : Z, (b <= a)%Z -> (0 <= a - b)%Z. +Proof. + intros a b. + intros. + apply Zplus_le_reg_l with b. + unfold Zminus in |- *. + rewrite (Zplus_comm a). + rewrite (Zplus_assoc b (- b)). + rewrite Zplus_opp_r. + simpl in |- *. + rewrite <- Zplus_0_r_reverse. + assumption. +Qed. + +Lemma Zlt_plus_plus : + forall m n p q : Z, (m < n)%Z -> (p < q)%Z -> (m + p < n + q)%Z. +Proof. + intros. + apply Zlt_trans with (m := (n + p)%Z). + rewrite Zplus_comm. + rewrite Zplus_comm with (n := n). + apply Zplus_lt_compat_l. + assumption. + apply Zplus_lt_compat_l. + assumption. +Qed. + +Lemma Zgt_plus_plus : + forall m n p q : Z, (m > n)%Z -> (p > q)%Z -> (m + p > n + q)%Z. + intros. + apply Zgt_trans with (m := (n + p)%Z). + rewrite Zplus_comm. + rewrite Zplus_comm with (n := n). + apply Zplus_gt_compat_l. + assumption. + apply Zplus_gt_compat_l. + assumption. +Qed. + +Lemma Zle_lt_plus_plus : + forall m n p q : Z, (m <= n)%Z -> (p < q)%Z -> (m + p < n + q)%Z. +Proof. + intros. + case (Zle_lt_or_eq m n). + assumption. + intro. + apply Zlt_plus_plus. + assumption. + assumption. + intro. + rewrite H1. + apply Zplus_lt_compat_l. + assumption. +Qed. + +Lemma Zge_gt_plus_plus : + forall m n p q : Z, (m >= n)%Z -> (p > q)%Z -> (m + p > n + q)%Z. +Proof. + intros. + case (Zle_lt_or_eq n m). + apply Zge_le. + assumption. + intro. + apply Zgt_plus_plus. + apply Zlt_gt. + assumption. + assumption. + intro. + rewrite H1. + apply Zplus_gt_compat_l. + assumption. +Qed. + +Lemma Zgt_ge_plus_plus : + forall m n p q : Z, (m > n)%Z -> (p >= q)%Z -> (m + p > n + q)%Z. +Proof. + intros. + rewrite Zplus_comm. + replace (n + q)%Z with (q + n)%Z. + apply Zge_gt_plus_plus. + assumption. + assumption. + apply Zplus_comm. +Qed. + +Lemma Zlt_resp_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x + y)%Z. +Proof. + intros. + rewrite <- Zplus_0_r with 0%Z. + apply Zlt_plus_plus; assumption. +Qed. + + +Lemma Zle_resp_neg : + forall x y : Z, (x <= 0)%Z -> (y <= 0)%Z -> (x + y <= 0)%Z. +Proof. + intros. + rewrite <- Zplus_0_r with 0%Z. + apply Zplus_le_compat; assumption. +Qed. + + +Lemma Zlt_pos_opp : forall x : Z, (0 < x)%Z -> (- x < 0)%Z. +Proof. + intros. + apply Zplus_lt_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + +Lemma Zlt_neg_opp : forall x : Z, (x < 0)%Z -> (0 < - x)%Z. +Proof. + intros. + apply Zplus_lt_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + + +Lemma Zle_neg_opp : forall x : Z, (x <= 0)%Z -> (0 <= - x)%Z. +Proof. + intros. + apply Zplus_le_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + +Lemma Zle_pos_opp : forall x : Z, (0 <= x)%Z -> (- x <= 0)%Z. +Proof. + intros. + apply Zplus_le_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + + +Lemma Zge_opp : forall x y : Z, (x <= y)%Z -> (- x >= - y)%Z. +Proof. + intros. + apply Zle_ge. + apply Zplus_le_reg_l with (p := (x + y)%Z). + ring_simplify (x + y + - y)%Z (x + y + - x)%Z. + assumption. +Qed. + + + +(* Omega can't solve this *) +Lemma Zmult_pos_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x * y)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + +Lemma Zmult_neg_neg : forall x y : Z, (x < 0)%Z -> (y < 0)%Z -> (0 < x * y)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + +Lemma Zmult_neg_pos : forall x y : Z, (x < 0)%Z -> (0 < y)%Z -> (x * y < 0)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + +Lemma Zmult_pos_neg : forall x y : Z, (0 < x)%Z -> (y < 0)%Z -> (x * y < 0)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + + + +Hint Resolve Zmult_pos_pos Zmult_neg_neg Zmult_neg_pos Zmult_pos_neg: zarith. + + +Lemma Zle_reg_mult_l : + forall x y a : Z, (0 < a)%Z -> (x <= y)%Z -> (a * x <= a * y)%Z. +Proof. + intros. + apply Zplus_le_reg_l with (p := (- a * x)%Z). + ring_simplify (- a * x + a * x)%Z. + replace (- a * x + a * y)%Z with ((y - x) * a)%Z. + apply Zmult_gt_0_le_0_compat. + apply Zlt_gt. + assumption. + unfold Zminus in |- *. + apply Zle_left. + assumption. + ring. +Qed. + +Lemma Zsimpl_plus_l_dep : + forall x y m n : Z, (x + m)%Z = (y + n)%Z -> x = y -> m = n. +Proof. + intros. + apply Zplus_reg_l with x. + rewrite <- H0 in H. + assumption. +Qed. + + +Lemma Zsimpl_plus_r_dep : + forall x y m n : Z, (m + x)%Z = (n + y)%Z -> x = y -> m = n. +Proof. + intros. + apply Zplus_reg_l with x. + rewrite Zplus_comm. + rewrite Zplus_comm with x n. + rewrite <- H0 in H. + assumption. +Qed. + +Lemma Zmult_simpl : + forall n m p q : Z, n = m -> p = q -> (n * p)%Z = (m * q)%Z. +Proof. + intros. + rewrite H. + rewrite H0. + reflexivity. +Qed. + +Lemma Zsimpl_mult_l : + forall n m p : Z, n <> 0%Z -> (n * m)%Z = (n * p)%Z -> m = p. +Proof. + intros. + apply Zplus_reg_l with (n := (- p)%Z). + replace (- p + p)%Z with 0%Z. + apply Zmult_integral_l with (n := n). + assumption. + replace ((- p + m) * n)%Z with (n * m + - (n * p))%Z. + apply Zegal_left. + assumption. + ring. + ring. +Qed. + +Lemma Zlt_reg_mult_l : + forall x y z : Z, (x > 0)%Z -> (y < z)%Z -> (x * y < x * z)%Z. (*QA*) +Proof. + intros. + case (Zcompare_Gt_spec x 0). + unfold Zgt in H. + assumption. + intros. + cut (x = Zpos x0). + intro. + rewrite H2. + unfold Zlt in H0. + unfold Zlt in |- *. + cut ((Zpos x0 * y ?= Zpos x0 * z)%Z = (y ?= z)%Z). + intro. + exact (trans_eq H3 H0). + apply Zcompare_mult_compat. + cut (x = (x + - (0))%Z). + intro. + exact (trans_eq H2 H1). + simpl in |- *. + apply (sym_eq (A:=Z)). + exact (Zplus_0_r x). +Qed. + + +Lemma Zlt_opp : forall x y : Z, (x < y)%Z -> (- x > - y)%Z. (*QA*) +Proof. + intros. + red in |- *. + apply sym_eq. + cut (Datatypes.Gt = (y ?= x)%Z). + intro. + cut ((y ?= x)%Z = (- x ?= - y)%Z). + intro. + exact (trans_eq H0 H1). + exact (Zcompare_opp y x). + apply sym_eq. + exact (Zlt_gt x y H). +Qed. + + +Lemma Zlt_conv_mult_l : + forall x y z : Z, (x < 0)%Z -> (y < z)%Z -> (x * y > x * z)%Z. (*QA*) +Proof. + intros. + cut (- x > 0)%Z. + intro. + cut (- x * y < - x * z)%Z. + intro. + cut (- (- x * y) > - (- x * z))%Z. + intro. + cut (- - (x * y) > - - (x * z))%Z. + intro. + cut ((- - (x * y))%Z = (x * y)%Z). + intro. + rewrite H5 in H4. + cut ((- - (x * z))%Z = (x * z)%Z). + intro. + rewrite H6 in H4. + assumption. + exact (Zopp_involutive (x * z)). + exact (Zopp_involutive (x * y)). + cut ((- (- x * y))%Z = (- - (x * y))%Z). + intro. + rewrite H4 in H3. + cut ((- (- x * z))%Z = (- - (x * z))%Z). + intro. + rewrite H5 in H3. + assumption. + cut ((- x * z)%Z = (- (x * z))%Z). + intro. + exact (f_equal Zopp H5). + exact (Zopp_mult_distr_l_reverse x z). + cut ((- x * y)%Z = (- (x * y))%Z). + intro. + exact (f_equal Zopp H4). + exact (Zopp_mult_distr_l_reverse x y). + exact (Zlt_opp (- x * y) (- x * z) H2). + exact (Zlt_reg_mult_l (- x) y z H1 H0). + exact (Zlt_opp x 0 H). +Qed. + +Lemma Zgt_not_eq : forall x y : Z, (x > y)%Z -> x <> y. (*QA*) +Proof. + intros. + cut (y < x)%Z. + intro. + cut (y <> x). + intro. + red in |- *. + intros. + cut (y = x). + intros. + apply H1. + assumption. + exact (sym_eq H2). + exact (Zorder.Zlt_not_eq y x H0). + exact (Zgt_lt x y H). +Qed. + +Lemma Zmult_resp_nonzero : + forall x y : Z, x <> 0%Z -> y <> 0%Z -> (x * y)%Z <> 0%Z. +Proof. + intros x y Hx Hy Hxy. + apply Hx. + apply Zmult_integral_l with y; assumption. +Qed. + + +Lemma Zopp_app : forall y : Z, y <> 0%Z -> (- y)%Z <> 0%Z. +Proof. + intros. + intro. + apply H. + apply Zplus_reg_l with (- y)%Z. + rewrite Zplus_opp_l. + rewrite H0. + simpl in |- *. + reflexivity. +Qed. + + +Lemma Zle_neq_Zlt : forall a b : Z, (a <= b)%Z -> b <> a -> (a < b)%Z. +Proof. + intros a b H H0. + case (Z_le_lt_eq_dec _ _ H); trivial. + intro; apply False_ind; apply H0; symmetry in |- *; assumption. +Qed. + +Lemma not_Zle_lt : forall x y : Z, ~ (y <= x)%Z -> (x < y)%Z. +Proof. + intros; apply Zgt_lt; apply Znot_le_gt; assumption. +Qed. + +Lemma not_Zlt : forall x y : Z, ~ (y < x)%Z -> (x <= y)%Z. +Proof. + intros x y H1 H2; apply H1; apply Zgt_lt; assumption. +Qed. + + +Lemma Zmult_absorb : + forall x y z : Z, x <> 0%Z -> (x * y)%Z = (x * z)%Z -> y = z. (*QA*) +Proof. + intros. + case (dec_eq y z). + intro. + assumption. + intro. + case (not_Zeq y z). + assumption. + intro. + case (not_Zeq x 0). + assumption. + intro. + apply False_ind. + cut (x * y > x * z)%Z. + intro. + cut ((x * y)%Z <> (x * z)%Z). + intro. + apply H5. + assumption. + exact (Zgt_not_eq (x * y) (x * z) H4). + exact (Zlt_conv_mult_l x y z H3 H2). + intro. + apply False_ind. + cut (x * y < x * z)%Z. + intro. + cut ((x * y)%Z <> (x * z)%Z). + intro. + apply H5. + assumption. + exact (Zorder.Zlt_not_eq (x * y) (x * z) H4). + cut (x > 0)%Z. + intro. + exact (Zlt_reg_mult_l x y z H4 H2). + exact (Zlt_gt 0 x H3). + intro. + apply False_ind. + cut (x * z < x * y)%Z. + intro. + cut ((x * z)%Z <> (x * y)%Z). + intro. + apply H4. + apply (sym_eq (A:=Z)). + assumption. + exact (Zorder.Zlt_not_eq (x * z) (x * y) H3). + apply False_ind. + case (not_Zeq x 0). + assumption. + intro. + cut (x * z > x * y)%Z. + intro. + cut ((x * z)%Z <> (x * y)%Z). + intro. + apply H5. + apply (sym_eq (A:=Z)). + assumption. + exact (Zgt_not_eq (x * z) (x * y) H4). + exact (Zlt_conv_mult_l x z y H3 H2). + intro. + cut (x * z < x * y)%Z. + intro. + cut ((x * z)%Z <> (x * y)%Z). + intro. + apply H5. + apply (sym_eq (A:=Z)). + assumption. + exact (Zorder.Zlt_not_eq (x * z) (x * y) H4). + cut (x > 0)%Z. + intro. + exact (Zlt_reg_mult_l x z y H4 H2). + exact (Zlt_gt 0 x H3). +Qed. + +Lemma Zlt_mult_mult : + forall a b c d : Z, + (0 < a)%Z -> (0 < d)%Z -> (a < b)%Z -> (c < d)%Z -> (a * c < b * d)%Z. +Proof. + intros. + apply Zlt_trans with (a * d)%Z. + apply Zlt_reg_mult_l. + Flip. + assumption. + rewrite Zmult_comm. + rewrite Zmult_comm with b d. + apply Zlt_reg_mult_l. + Flip. + assumption. +Qed. + +Lemma Zgt_mult_conv_absorb_l : + forall a x y : Z, (a < 0)%Z -> (a * x > a * y)%Z -> (x < y)%Z. (*QC*) +Proof. + intros. + case (dec_eq x y). + intro. + apply False_ind. + rewrite H1 in H0. + cut ((a * y)%Z = (a * y)%Z). + change ((a * y)%Z <> (a * y)%Z) in |- *. + apply Zgt_not_eq. + assumption. + trivial. + + intro. + case (not_Zeq x y H1). + trivial. + + intro. + apply False_ind. + cut (a * y > a * x)%Z. + apply Zgt_asym with (m := (a * y)%Z) (n := (a * x)%Z). + assumption. + apply Zlt_conv_mult_l. + assumption. + assumption. +Qed. + +Lemma Zgt_mult_reg_absorb_l : + forall a x y : Z, (a > 0)%Z -> (a * x > a * y)%Z -> (x > y)%Z. (*QC*) +Proof. + intros. + cut (- - a > - - (0))%Z. + intro. + cut (- a < - (0))%Z. + simpl in |- *. + intro. + replace x with (- - x)%Z. + replace y with (- - y)%Z. + apply Zlt_opp. + apply Zgt_mult_conv_absorb_l with (a := (- a)%Z) (x := (- x)%Z). + assumption. + rewrite Zmult_opp_opp. + rewrite Zmult_opp_opp. + assumption. + apply Zopp_involutive. + apply Zopp_involutive. + apply Zgt_lt. + apply Zlt_opp. + apply Zgt_lt. + assumption. + simpl in |- *. + rewrite Zopp_involutive. + assumption. +Qed. + +Lemma Zopp_Zlt : forall x y : Z, (y < x)%Z -> (- x < - y)%Z. +Proof. + intros x y Hyx. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + replace (-1 * - y)%Z with y. + replace (-1 * - x)%Z with x. + Flip. + ring. + ring. +Qed. + + +Lemma Zmin_cancel_Zlt : forall x y : Z, (- x < - y)%Z -> (y < x)%Z. +Proof. + intros. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + replace (-1 * y)%Z with (- y)%Z. + replace (-1 * x)%Z with (- x)%Z. + apply Zlt_gt. + assumption. + ring. + ring. +Qed. + + +Lemma Zmult_cancel_Zle : + forall a x y : Z, (a < 0)%Z -> (a * x <= a * y)%Z -> (y <= x)%Z. +Proof. + intros. + case (Z_le_gt_dec y x). + trivial. + intro. + apply False_ind. + apply (Zlt_irrefl (a * x)). + apply Zle_lt_trans with (m := (a * y)%Z). + assumption. + apply Zgt_lt. + apply Zlt_conv_mult_l. + assumption. + apply Zgt_lt. + assumption. +Qed. + +Lemma Zlt_mult_cancel_l : + forall x y z : Z, (0 < x)%Z -> (x * y < x * z)%Z -> (y < z)%Z. +Proof. + intros. + apply Zgt_lt. + apply Zgt_mult_reg_absorb_l with x. + apply Zlt_gt. + assumption. + apply Zlt_gt. + assumption. +Qed. + + +Lemma Zmin_cancel_Zle : forall x y : Z, (- x <= - y)%Z -> (y <= x)%Z. +Proof. + intros. + apply Zmult_cancel_Zle with (a := (-1)%Z). + constructor. + replace (-1 * y)%Z with (- y)%Z. + replace (-1 * x)%Z with (- x)%Z. + assumption. + ring. + ring. +Qed. + + + +Lemma Zmult_resp_Zle : + forall a x y : Z, (0 < a)%Z -> (a * y <= a * x)%Z -> (y <= x)%Z. +Proof. + intros. + case (Z_le_gt_dec y x). + trivial. + intro. + apply False_ind. + apply (Zlt_irrefl (a * y)). + apply Zle_lt_trans with (m := (a * x)%Z). + assumption. + apply Zlt_reg_mult_l. + apply Zlt_gt. + assumption. + apply Zgt_lt. + assumption. +Qed. + +Lemma Zopp_Zle : forall x y : Z, (y <= x)%Z -> (- x <= - y)%Z. +Proof. + intros. + apply Zmult_cancel_Zle with (a := (-1)%Z). + constructor. + replace (-1 * - y)%Z with y. + replace (-1 * - x)%Z with x. + assumption. + clear y H; ring. + clear x H; ring. +Qed. + + +Lemma Zle_lt_eq_S : forall x y : Z, (x <= y)%Z -> (y < x + 1)%Z -> y = x. +Proof. + intros. + case (Z_le_lt_eq_dec x y H). + intro H1. + apply False_ind. + generalize (Zlt_le_succ x y H1). + intro. + apply (Zlt_not_le y (x + 1) H0). + replace (x + 1)%Z with (Zsucc x). + assumption. + reflexivity. + intro H1. + symmetry in |- *. + assumption. +Qed. + +Lemma Zlt_le_eq_S : + forall x y : Z, (x < y)%Z -> (y <= x + 1)%Z -> y = (x + 1)%Z. +Proof. + intros. + case (Z_le_lt_eq_dec y (x + 1) H0). + intro H1. + apply False_ind. + generalize (Zlt_le_succ x y H). + intro. + apply (Zlt_not_le y (x + 1) H1). + replace (x + 1)%Z with (Zsucc x). + assumption. + reflexivity. + trivial. +Qed. + + +Lemma double_not_equal_zero : + forall c d : Z, ~ (c = 0%Z /\ d = 0%Z) -> c <> d \/ c <> 0%Z. +Proof. + intros. + case (Z_zerop c). + intro. + rewrite e. + left. + apply sym_not_eq. + intro. + apply H; repeat split; assumption. + intro; right; assumption. +Qed. + +Lemma triple_not_equal_zero : + forall a b c : Z, + ~ (a = 0%Z /\ b = 0%Z /\ c = 0%Z) -> a <> 0%Z \/ b <> 0%Z \/ c <> 0%Z. +Proof. + intros a b c H; case (Z_zerop a); intro Ha; + [ case (Z_zerop b); intro Hb; + [ case (Z_zerop c); intro Hc; + [ apply False_ind; apply H; repeat split | right; right ] + | right; left ] + | left ]; assumption. +Qed. + +Lemma mediant_1 : + forall m n m' n' : Z, (m' * n < m * n')%Z -> ((m + m') * n < m * (n + n'))%Z. +Proof. + intros. + rewrite Zmult_plus_distr_r. + rewrite Zmult_plus_distr_l. + apply Zplus_lt_compat_l. + assumption. +Qed. + +Lemma mediant_2 : + forall m n m' n' : Z, + (m' * n < m * n')%Z -> (m' * (n + n') < (m + m') * n')%Z. +Proof. + intros. + rewrite Zmult_plus_distr_l. + rewrite Zmult_plus_distr_r. + apply Zplus_lt_compat_r. + assumption. +Qed. + + +Lemma mediant_3 : + forall a b m n m' n' : Z, + (0 <= a * m + b * n)%Z -> + (0 <= a * m' + b * n')%Z -> (0 <= a * (m + m') + b * (n + n'))%Z. +Proof. + intros. + replace (a * (m + m') + b * (n + n'))%Z with + (a * m + b * n + (a * m' + b * n'))%Z. + apply Zplus_le_0_compat. + assumption. + assumption. + ring. +Qed. + +Lemma fraction_lt_trans : + forall a b c d e f : Z, + (0 < b)%Z -> + (0 < d)%Z -> + (0 < f)%Z -> (a * d < c * b)%Z -> (c * f < e * d)%Z -> (a * f < e * b)%Z. +Proof. + intros. + apply Zgt_lt. + apply Zgt_mult_reg_absorb_l with d. + Flip. + apply Zgt_trans with (c * b * f)%Z. + replace (d * (e * b))%Z with (b * (e * d))%Z. + replace (c * b * f)%Z with (b * (c * f))%Z. + apply Zlt_gt. + apply Zlt_reg_mult_l. + Flip. + assumption. + ring. + ring. + replace (c * b * f)%Z with (f * (c * b))%Z. + replace (d * (a * f))%Z with (f * (a * d))%Z. + apply Zlt_gt. + apply Zlt_reg_mult_l. + Flip. + assumption. + ring. + ring. +Qed. + + +Lemma square_pos : forall a : Z, a <> 0%Z -> (0 < a * a)%Z. +Proof. + intros [| p| p]; intros; [ Falsum | constructor | constructor ]. +Qed. + +Hint Resolve square_pos: zarith. + +(*###########################################################################*) +(** Properties of positive numbers, mapping between Z and nat *) +(*###########################################################################*) + + +Definition Z2positive (z : Z) := + match z with + | Zpos p => p + | Zneg p => p + | Z0 => 1%positive + end. + + +Lemma ZL9 : forall p : positive, Z_of_nat (nat_of_P p) = Zpos p. (*QF*) +Proof. + intro. + cut (exists h : nat, nat_of_P p = S h). + intro. + case H. + intros. + unfold Z_of_nat in |- *. + rewrite H0. + + apply f_equal with (A := positive) (B := Z) (f := Zpos). + cut (P_of_succ_nat (nat_of_P p) = P_of_succ_nat (S x)). + intro. + rewrite P_of_succ_nat_o_nat_of_P_eq_succ in H1. + cut (Ppred (Psucc p) = Ppred (P_of_succ_nat (S x))). + intro. + rewrite Ppred_succ in H2. + simpl in H2. + rewrite Ppred_succ in H2. + apply sym_eq. + assumption. + apply f_equal with (A := positive) (B := positive) (f := Ppred). + assumption. + apply f_equal with (f := P_of_succ_nat). + assumption. + apply ZL4. +Qed. + +Coercion Z_of_nat : nat >-> Z. + +Lemma ZERO_lt_POS : forall p : positive, (0 < Zpos p)%Z. +Proof. + intros. + constructor. +Qed. + + +Lemma POS_neq_ZERO : forall p : positive, Zpos p <> 0%Z. +Proof. + intros. + apply sym_not_eq. + apply Zorder.Zlt_not_eq. + apply ZERO_lt_POS. +Qed. + +Lemma NEG_neq_ZERO : forall p : positive, Zneg p <> 0%Z. +Proof. + intros. + apply Zorder.Zlt_not_eq. + unfold Zlt in |- *. + constructor. +Qed. + + +Lemma POS_resp_eq : forall p0 p1 : positive, Zpos p0 = Zpos p1 -> p0 = p1. +Proof. + intros. + injection H. + trivial. +Qed. + +Lemma nat_nat_pos : forall m n : nat, ((m + 1) * (n + 1) > 0)%Z. (*QF*) +Proof. + intros. + apply Zlt_gt. + cut (Z_of_nat m + 1 > 0)%Z. + intro. + cut (0 < Z_of_nat n + 1)%Z. + intro. + cut ((Z_of_nat m + 1) * 0 < (Z_of_nat m + 1) * (Z_of_nat n + 1))%Z. + rewrite Zmult_0_r. + intro. + assumption. + + apply Zlt_reg_mult_l. + assumption. + assumption. + change (0 < Zsucc (Z_of_nat n))%Z in |- *. + apply Zle_lt_succ. + change (Z_of_nat 0 <= Z_of_nat n)%Z in |- *. + apply Znat.inj_le. + apply le_O_n. + apply Zlt_gt. + change (0 < Zsucc (Z_of_nat m))%Z in |- *. + apply Zle_lt_succ. + change (Z_of_nat 0 <= Z_of_nat m)%Z in |- *. + apply Znat.inj_le. + apply le_O_n. +Qed. + + +Theorem S_predn : forall m : nat, m <> 0 -> S (pred m) = m. (*QF*) +Proof. + intros. + case (O_or_S m). + intro. + case s. + intros. + rewrite <- e. + rewrite <- pred_Sn with (n := x). + trivial. + intro. + apply False_ind. + apply H. + apply sym_eq. + assumption. +Qed. + +Lemma absolu_1 : forall x : Z, Zabs_nat x = 0 -> x = 0%Z. (*QF*) +Proof. + intros. + case (dec_eq x 0). + intro. + assumption. + intro. + apply False_ind. + cut ((x < 0)%Z \/ (x > 0)%Z). + intro. + ElimCompare x 0%Z. + intro. + cut (x = 0%Z). + assumption. + cut ((x ?= 0)%Z = Datatypes.Eq -> x = 0%Z). + intro. + apply H3. + assumption. + apply proj1 with (B := x = 0%Z -> (x ?= 0)%Z = Datatypes.Eq). + change ((x ?= 0)%Z = Datatypes.Eq <-> x = 0%Z) in |- *. + apply Zcompare_Eq_iff_eq. + + (***) + intro. + cut (exists h : nat, Zabs_nat x = S h). + intro. + case H3. + rewrite H. + exact O_S. + + change (x < 0)%Z in H2. + cut (0 > x)%Z. + intro. + cut (exists p : positive, (0 + - x)%Z = Zpos p). + simpl in |- *. + intro. + case H4. + intros. + cut (exists q : positive, x = Zneg q). + intro. + case H6. + intros. + rewrite H7. + unfold Zabs_nat in |- *. + generalize x1. + exact ZL4. + cut (x = (- Zpos x0)%Z). + simpl in |- *. + intro. + exists x0. + assumption. + cut ((- - x)%Z = x). + intro. + rewrite <- H6. + exact (f_equal Zopp H5). + apply Zopp_involutive. + apply Zcompare_Gt_spec. + assumption. + apply Zlt_gt. + assumption. + + (***) + intro. + cut (exists h : nat, Zabs_nat x = S h). + intro. + case H3. + rewrite H. + exact O_S. + + cut (exists p : positive, (x + - (0))%Z = Zpos p). + simpl in |- *. + rewrite Zplus_0_r. + intro. + case H3. + intros. + rewrite H4. + unfold Zabs_nat in |- *. + generalize x0. + exact ZL4. + apply Zcompare_Gt_spec. + assumption. + + (***) + cut ((x < 0)%Z \/ (0 < x)%Z). + intro. + apply + or_ind with (A := (x < 0)%Z) (B := (0 < x)%Z) (P := (x < 0)%Z \/ (x > 0)%Z). + intro. + left. + assumption. + intro. + right. + apply Zlt_gt. + assumption. + assumption. + apply not_Zeq. + assumption. +Qed. + +Lemma absolu_2 : forall x : Z, x <> 0%Z -> Zabs_nat x <> 0. (*QF*) +Proof. + intros. + intro. + apply H. + apply absolu_1. + assumption. +Qed. + + + + +Lemma absolu_inject_nat : forall n : nat, Zabs_nat (Z_of_nat n) = n. +Proof. + simple induction n; simpl in |- *. + reflexivity. + intros. + apply nat_of_P_o_P_of_succ_nat_eq_succ. +Qed. + + +Lemma eq_inj : forall m n : nat, m = n :>Z -> m = n. +Proof. + intros. + generalize (f_equal Zabs_nat H). + intro. + rewrite (absolu_inject_nat m) in H0. + rewrite (absolu_inject_nat n) in H0. + assumption. +Qed. + +Lemma lt_inj : forall m n : nat, (m < n)%Z -> m < n. +Proof. + intros. + omega. +Qed. + +Lemma le_inj : forall m n : nat, (m <= n)%Z -> m <= n. +Proof. + intros. + omega. +Qed. + + +Lemma inject_nat_S_inf : forall x : Z, (0 < x)%Z -> {n : nat | x = S n}. +Proof. + intros [| p| p] Hp; try discriminate Hp. + exists (pred (nat_of_P p)). + rewrite S_predn. + symmetry in |- *; apply ZL9. + clear Hp; + apply sym_not_equal; apply lt_O_neq; apply lt_O_nat_of_P. +Qed. + + + +Lemma le_absolu : + forall x y : Z, + (0 <= x)%Z -> (0 <= y)%Z -> (x <= y)%Z -> Zabs_nat x <= Zabs_nat y. +Proof. + intros [| x| x] [| y| y] Hx Hy Hxy; + apply le_O_n || + (try + match goal with + | id1:(0 <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= 0)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + end). + simpl in |- *. + apply le_inj. + do 2 rewrite ZL9. + assumption. +Qed. + +Lemma lt_absolu : + forall x y : Z, + (0 <= x)%Z -> (0 <= y)%Z -> (x < y)%Z -> Zabs_nat x < Zabs_nat y. +Proof. + intros [| x| x] [| y| y] Hx Hy Hxy; inversion Hxy; + try + match goal with + | id1:(0 <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= 0)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + end; simpl in |- *; apply lt_inj; repeat rewrite ZL9; + assumption. +Qed. + +Lemma absolu_plus : + forall x y : Z, + (0 <= x)%Z -> (0 <= y)%Z -> Zabs_nat (x + y) = Zabs_nat x + Zabs_nat y. +Proof. + intros [| x| x] [| y| y] Hx Hy; trivial; + try + match goal with + | id1:(0 <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= 0)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + end. + rewrite <- BinInt.Zpos_plus_distr. + unfold Zabs_nat in |- *. + apply nat_of_P_plus_morphism. +Qed. + +Lemma pred_absolu : + forall x : Z, (0 < x)%Z -> pred (Zabs_nat x) = Zabs_nat (x - 1). +Proof. + intros x Hx. + generalize (Z_lt_lt_S_eq_dec 0 x Hx); simpl in |- *; intros [H1| H1]; + [ replace (Zabs_nat x) with (Zabs_nat (x - 1 + 1)); + [ idtac | apply f_equal with Z; auto with zarith ]; + rewrite absolu_plus; + [ unfold Zabs_nat at 2, nat_of_P, Piter_op in |- *; omega + | auto with zarith + | intro; discriminate ] + | rewrite <- H1; reflexivity ]. +Qed. + +Definition pred_nat : forall (x : Z) (Hx : (0 < x)%Z), nat. +intros [| px| px] Hx; try abstract (discriminate Hx). +exact (pred (nat_of_P px)). +Defined. + +Lemma pred_nat_equal : + forall (x : Z) (Hx1 Hx2 : (0 < x)%Z), pred_nat x Hx1 = pred_nat x Hx2. +Proof. + intros [| px| px] Hx1 Hx2; try (discriminate Hx1); trivial. +Qed. + +Let pred_nat_unfolded_subproof px : + Pos.to_nat px <> 0. +Proof. +apply sym_not_equal; apply lt_O_neq; apply lt_O_nat_of_P. +Qed. + +Lemma pred_nat_unfolded : + forall (x : Z) (Hx : (0 < x)%Z), x = S (pred_nat x Hx). +Proof. + intros [| px| px] Hx; try discriminate Hx. + unfold pred_nat in |- *. + rewrite S_predn. + symmetry in |- *; apply ZL9. + clear Hx; apply pred_nat_unfolded_subproof. +Qed. + +Lemma absolu_pred_nat : + forall (m : Z) (Hm : (0 < m)%Z), S (pred_nat m Hm) = Zabs_nat m. +Proof. + intros [| px| px] Hx; try discriminate Hx. + unfold pred_nat in |- *. + rewrite S_predn. + reflexivity. + apply pred_nat_unfolded_subproof. +Qed. + +Lemma pred_nat_absolu : + forall (m : Z) (Hm : (0 < m)%Z), pred_nat m Hm = Zabs_nat (m - 1). +Proof. + intros [| px| px] Hx; try discriminate Hx. + unfold pred_nat in |- *. + rewrite <- pred_absolu; reflexivity || assumption. +Qed. + +Lemma minus_pred_nat : + forall (n m : Z) (Hn : (0 < n)%Z) (Hm : (0 < m)%Z) (Hnm : (0 < n - m)%Z), + S (pred_nat n Hn) - S (pred_nat m Hm) = S (pred_nat (n - m) Hnm). +Proof. + intros. + simpl in |- *. + destruct n; try discriminate Hn. + destruct m; try discriminate Hm. + unfold pred_nat at 1 2 in |- *. + rewrite minus_pred; try apply lt_O_nat_of_P. + apply eq_inj. + rewrite <- pred_nat_unfolded. + rewrite Znat.inj_minus1. + repeat rewrite ZL9. + reflexivity. + apply le_inj. + apply Zlt_le_weak. + repeat rewrite ZL9. + apply Zlt_O_minus_lt. + assumption. +Qed. + + +(*###########################################################################*) +(** Properties of Zsgn *) +(*###########################################################################*) + + +Lemma Zsgn_1 : + forall x : Z, {Zsgn x = 0%Z} + {Zsgn x = 1%Z} + {Zsgn x = (-1)%Z}. (*QF*) +Proof. + intros. + case x. + left. + left. + unfold Zsgn in |- *. + reflexivity. + intro. + simpl in |- *. + left. + right. + reflexivity. + intro. + right. + simpl in |- *. + reflexivity. +Qed. + + +Lemma Zsgn_2 : forall x : Z, Zsgn x = 0%Z -> x = 0%Z. (*QF*) +Proof. + intros [| p1| p1]; simpl in |- *; intro H; constructor || discriminate H. +Qed. + + +Lemma Zsgn_3 : forall x : Z, x <> 0%Z -> Zsgn x <> 0%Z. (*QF*) +Proof. + intro. + case x. + intros. + apply False_ind. + apply H. + reflexivity. + intros. + simpl in |- *. + discriminate. + intros. + simpl in |- *. + discriminate. +Qed. + + + + +Theorem Zsgn_4 : forall a : Z, a = (Zsgn a * Zabs_nat a)%Z. (*QF*) +Proof. + intro. + case a. + simpl in |- *. + reflexivity. + intro. + unfold Zsgn in |- *. + unfold Zabs_nat in |- *. + rewrite Zmult_1_l. + symmetry in |- *. + apply ZL9. + intros. + unfold Zsgn in |- *. + unfold Zabs_nat in |- *. + rewrite ZL9. + constructor. +Qed. + + +Theorem Zsgn_5 : + forall a b x y : Z, + x <> 0%Z -> + y <> 0%Z -> + (Zsgn a * x)%Z = (Zsgn b * y)%Z -> (Zsgn a * y)%Z = (Zsgn b * x)%Z. (*QF*) +Proof. + intros a b x y H H0. + case a. + + case b. + simpl in |- *. + trivial. + + intro. + unfold Zsgn in |- *. + intro. + rewrite Zmult_1_l in H1. + simpl in H1. + apply False_ind. + apply H0. + symmetry in |- *. + assumption. + intro. + unfold Zsgn in |- *. + intro. + apply False_ind. + apply H0. + apply Zopp_inj. + simpl in |- *. + transitivity (-1 * y)%Z. + constructor. + transitivity (0 * x)%Z. + symmetry in |- *. + assumption. + simpl in |- *. + reflexivity. + intro. + unfold Zsgn at 1 in |- *. + unfold Zsgn at 2 in |- *. + intro. + transitivity y. + rewrite Zmult_1_l. + reflexivity. + transitivity (Zsgn b * (Zsgn b * y))%Z. + case (Zsgn_1 b). + intro. + case s. + intro. + apply False_ind. + apply H. + rewrite e in H1. + change ((1 * x)%Z = 0%Z) in H1. + rewrite Zmult_1_l in H1. + assumption. + intro. + rewrite e. + rewrite Zmult_1_l. + rewrite Zmult_1_l. + reflexivity. + intro. + rewrite e. + ring. + rewrite Zmult_1_l in H1. + rewrite H1. + reflexivity. + intro. + unfold Zsgn at 1 in |- *. + unfold Zsgn at 2 in |- *. + intro. + transitivity (Zsgn b * (-1 * (Zsgn b * y)))%Z. + case (Zsgn_1 b). + intros. + case s. + intro. + apply False_ind. + apply H. + apply Zopp_inj. + transitivity (-1 * x)%Z. + ring. + unfold Zopp in |- *. + rewrite e in H1. + transitivity (0 * y)%Z. + assumption. + simpl in |- *. + reflexivity. + intro. + rewrite e. + ring. + intro. + rewrite e. + ring. + rewrite <- H1. + ring. +Qed. + +Lemma Zsgn_6 : forall x : Z, x = 0%Z -> Zsgn x = 0%Z. +Proof. + intros. + rewrite H. + simpl in |- *. + reflexivity. +Qed. + + +Lemma Zsgn_7 : forall x : Z, (x > 0)%Z -> Zsgn x = 1%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + apply (Zlt_irrefl 0). + Flip. + intros. + simpl in |- *. + reflexivity. + intros. + apply False_ind. + apply (Zlt_irrefl (Zneg p)). + apply Zlt_trans with 0%Z. + constructor. + Flip. +Qed. + + +Lemma Zsgn_7' : forall x : Z, (0 < x)%Z -> Zsgn x = 1%Z. +Proof. + intros; apply Zsgn_7; Flip. +Qed. + + +Lemma Zsgn_8 : forall x : Z, (x < 0)%Z -> Zsgn x = (-1)%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + apply (Zlt_irrefl 0). + assumption. + intros. + apply False_ind. + apply (Zlt_irrefl 0). + apply Zlt_trans with (Zpos p). + constructor. + assumption. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zsgn_9 : forall x : Z, Zsgn x = 1%Z -> (0 < x)%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + simpl in H. + discriminate. + intros. + constructor. + intros. + apply False_ind. + discriminate. +Qed. + +Lemma Zsgn_10 : forall x : Z, Zsgn x = (-1)%Z -> (x < 0)%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + discriminate. + intros. + apply False_ind. + discriminate. + intros. + constructor. +Qed. + +Lemma Zsgn_11 : forall x : Z, (Zsgn x < 0)%Z -> (x < 0)%Z. +Proof. + intros. + apply Zsgn_10. + case (Zsgn_1 x). + intro. + apply False_ind. + case s. + intro. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + apply (H0 e). + intro. + rewrite e in H. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + discriminate. + trivial. +Qed. + +Lemma Zsgn_12 : forall x : Z, (0 < Zsgn x)%Z -> (0 < x)%Z. +Proof. + intros. + apply Zsgn_9. + case (Zsgn_1 x). + intro. + case s. + intro. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + generalize (sym_eq e). + intro. + apply False_ind. + apply (H0 H1). + trivial. + intro. + rewrite e in H. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + apply False_ind. + discriminate. +Qed. + +Lemma Zsgn_13 : forall x : Z, (0 <= Zsgn x)%Z -> (0 <= x)%Z. +Proof. + intros. + case (Z_le_lt_eq_dec 0 (Zsgn x) H). + intro. + apply Zlt_le_weak. + apply Zsgn_12. + assumption. + intro. + assert (x = 0%Z). + apply Zsgn_2. + symmetry in |- *. + assumption. + rewrite H0. + apply Zle_refl. +Qed. + +Lemma Zsgn_14 : forall x : Z, (Zsgn x <= 0)%Z -> (x <= 0)%Z. +Proof. + intros. + case (Z_le_lt_eq_dec (Zsgn x) 0 H). + intro. + apply Zlt_le_weak. + apply Zsgn_11. + assumption. + intro. + assert (x = 0%Z). + apply Zsgn_2. + assumption. + rewrite H0. + apply Zle_refl. +Qed. + +Lemma Zsgn_15 : forall x y : Z, Zsgn (x * y) = (Zsgn x * Zsgn y)%Z. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; constructor. +Qed. + +Lemma Zsgn_16 : + forall x y : Z, + Zsgn (x * y) = 1%Z -> {(0 < x)%Z /\ (0 < y)%Z} + {(x < 0)%Z /\ (y < 0)%Z}. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + try discriminate H; [ left | right ]; repeat split. +Qed. + +Lemma Zsgn_17 : + forall x y : Z, + Zsgn (x * y) = (-1)%Z -> {(0 < x)%Z /\ (y < 0)%Z} + {(x < 0)%Z /\ (0 < y)%Z}. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + try discriminate H; [ left | right ]; repeat split. +Qed. + +Lemma Zsgn_18 : forall x y : Z, Zsgn (x * y) = 0%Z -> {x = 0%Z} + {y = 0%Z}. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + try discriminate H; [ left | right | right ]; constructor. +Qed. + + + +Lemma Zsgn_19 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 < x + y)%Z. +Proof. + Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + discriminate H || (constructor || apply Zsgn_12; assumption). +Qed. + +Lemma Zsgn_20 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x + y < 0)%Z. +Proof. + Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + discriminate H || (constructor || apply Zsgn_11; assumption). +Qed. + + +Lemma Zsgn_21 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= x)%Z. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_22 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x <= 0)%Z. +Proof. + Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_23 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= y)%Z. +Proof. + intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros H H0; discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_24 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (y <= 0)%Z. +Proof. + intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros H H0; discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_25 : forall x : Z, Zsgn (- x) = (- Zsgn x)%Z. +Proof. + intros [| p1| p1]; simpl in |- *; reflexivity. +Qed. + + +Lemma Zsgn_26 : forall x : Z, (0 < x)%Z -> (0 < Zsgn x)%Z. +Proof. + intros [| p| p] Hp; trivial. +Qed. + +Lemma Zsgn_27 : forall x : Z, (x < 0)%Z -> (Zsgn x < 0)%Z. +Proof. + intros [| p| p] Hp; trivial. +Qed. + +Hint Resolve Zsgn_1 Zsgn_2 Zsgn_3 Zsgn_4 Zsgn_5 Zsgn_6 Zsgn_7 Zsgn_7' Zsgn_8 + Zsgn_9 Zsgn_10 Zsgn_11 Zsgn_12 Zsgn_13 Zsgn_14 Zsgn_15 Zsgn_16 Zsgn_17 + Zsgn_18 Zsgn_19 Zsgn_20 Zsgn_21 Zsgn_22 Zsgn_23 Zsgn_24 Zsgn_25 Zsgn_26 + Zsgn_27: zarith. + +(*###########################################################################*) +(** Properties of Zabs *) +(*###########################################################################*) + +Lemma Zabs_1 : forall z p : Z, (Zabs z < p)%Z -> (z < p)%Z /\ (- p < z)%Z. +Proof. + intros z p. + case z. + intros. + simpl in H. + split. + assumption. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + replace (-1)%Z with (Zpred 0). + apply Zlt_pred. + simpl; trivial. + ring_simplify (-1 * - p)%Z (-1 * 0)%Z. + apply Zlt_gt. + assumption. + + intros. + simpl in H. + split. + assumption. + apply Zlt_trans with (m := 0%Z). + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + replace (-1)%Z with (Zpred 0). + apply Zlt_pred. + simpl; trivial. + ring_simplify (-1 * - p)%Z (-1 * 0)%Z. + apply Zlt_gt. + apply Zlt_trans with (m := Zpos p0). + constructor. + assumption. + constructor. + + intros. + simpl in H. + split. + apply Zlt_trans with (m := Zpos p0). + constructor. + assumption. + + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + replace (-1)%Z with (Zpred 0). + apply Zlt_pred. + simpl;trivial. + ring_simplify (-1 * - p)%Z. + replace (-1 * Zneg p0)%Z with (- Zneg p0)%Z. + replace (- Zneg p0)%Z with (Zpos p0). + apply Zlt_gt. + assumption. + symmetry in |- *. + apply Zopp_neg. + rewrite Zopp_mult_distr_l_reverse with (n := 1%Z). + simpl in |- *. + constructor. +Qed. + + +Lemma Zabs_2 : forall z p : Z, (Zabs z > p)%Z -> (z > p)%Z \/ (- p > z)%Z. +Proof. + intros z p. + case z. + intros. + simpl in H. + left. + assumption. + + intros. + simpl in H. + left. + assumption. + + intros. + simpl in H. + right. + apply Zlt_gt. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + ring_simplify (-1 * - p)%Z. + replace (-1 * Zneg p0)%Z with (Zpos p0). + assumption. + reflexivity. +Qed. + +Lemma Zabs_3 : forall z p : Z, (z < p)%Z /\ (- p < z)%Z -> (Zabs z < p)%Z. +Proof. + intros z p. + case z. + intro. + simpl in |- *. + elim H. + intros. + assumption. + + intros. + elim H. + intros. + simpl in |- *. + assumption. + + intros. + elim H. + intros. + simpl in |- *. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + replace (-1 * Zpos p0)%Z with (Zneg p0). + replace (-1 * p)%Z with (- p)%Z. + apply Zlt_gt. + assumption. + ring. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zabs_4 : forall z p : Z, (Zabs z < p)%Z -> (- p < z < p)%Z. +Proof. + intros. + split. + apply proj2 with (A := (z < p)%Z). + apply Zabs_1. + assumption. + apply proj1 with (B := (- p < z)%Z). + apply Zabs_1. + assumption. +Qed. + + +Lemma Zabs_5 : forall z p : Z, (Zabs z <= p)%Z -> (- p <= z <= p)%Z. +Proof. + intros. + split. + replace (- p)%Z with (Zsucc (- Zsucc p)). + apply Zlt_le_succ. + apply proj2 with (A := (z < Zsucc p)%Z). + apply Zabs_1. + apply Zle_lt_succ. + assumption. + unfold Zsucc in |- *. + ring. + apply Zlt_succ_le. + apply proj1 with (B := (- Zsucc p < z)%Z). + apply Zabs_1. + apply Zle_lt_succ. + assumption. +Qed. + +Lemma Zabs_6 : forall z p : Z, (Zabs z <= p)%Z -> (z <= p)%Z. +Proof. + intros. + apply proj2 with (A := (- p <= z)%Z). + apply Zabs_5. + assumption. +Qed. + +Lemma Zabs_7 : forall z p : Z, (Zabs z <= p)%Z -> (- p <= z)%Z. +Proof. + intros. + apply proj1 with (B := (z <= p)%Z). + apply Zabs_5. + assumption. +Qed. + +Lemma Zabs_8 : forall z p : Z, (- p <= z <= p)%Z -> (Zabs z <= p)%Z. +Proof. + intros. + apply Zlt_succ_le. + apply Zabs_3. + elim H. + intros. + split. + apply Zle_lt_succ. + assumption. + apply Zlt_le_trans with (m := (- p)%Z). + apply Zgt_lt. + apply Zlt_opp. + apply Zlt_succ. + assumption. +Qed. + +Lemma Zabs_min : forall z : Z, Zabs z = Zabs (- z). +Proof. + intro. + case z. + simpl in |- *. + reflexivity. + intro. + simpl in |- *. + reflexivity. + intro. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zabs_9 : + forall z p : Z, (0 <= p)%Z -> (p < z)%Z \/ (z < - p)%Z -> (p < Zabs z)%Z. +Proof. + intros. + case H0. + intro. + replace (Zabs z) with z. + assumption. + symmetry in |- *. + apply Zabs_eq. + apply Zlt_le_weak. + apply Zle_lt_trans with (m := p). + assumption. + assumption. + intro. + cut (Zabs z = (- z)%Z). + intro. + rewrite H2. + apply Zmin_cancel_Zlt. + ring_simplify (- - z)%Z. + assumption. + rewrite Zabs_min. + apply Zabs_eq. + apply Zlt_le_weak. + apply Zle_lt_trans with (m := p). + assumption. + apply Zmin_cancel_Zlt. + ring_simplify (- - z)%Z. + assumption. +Qed. + +Lemma Zabs_10 : forall z : Z, (0 <= Zabs z)%Z. +Proof. + intro. + case (Z_zerop z). + intro. + rewrite e. + simpl in |- *. + apply Zle_refl. + intro. + case (not_Zeq z 0 n). + intro. + apply Zlt_le_weak. + apply Zabs_9. + apply Zle_refl. + simpl in |- *. + right. + assumption. + intro. + apply Zlt_le_weak. + apply Zabs_9. + apply Zle_refl. + simpl in |- *. + left. + assumption. +Qed. + +Lemma Zabs_11 : forall z : Z, z <> 0%Z -> (0 < Zabs z)%Z. +Proof. + intros. + apply Zabs_9. + apply Zle_refl. + simpl in |- *. + apply not_Zeq. + intro. + apply H. + symmetry in |- *. + assumption. +Qed. + +Lemma Zabs_12 : forall z m : Z, (m < Zabs z)%Z -> {(m < z)%Z} + {(z < - m)%Z}. +Proof. + intros [| p| p] m; simpl in |- *; intros H; + [ left | left | right; apply Zmin_cancel_Zlt; rewrite Zopp_involutive ]; + assumption. +Qed. + +Lemma Zabs_mult : forall z p : Z, Zabs (z * p) = (Zabs z * Zabs p)%Z. +Proof. + intros. + case z. + simpl in |- *. + reflexivity. + case p. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. + case p. + intro. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zabs_plus : forall z p : Z, (Zabs (z + p) <= Zabs z + Zabs p)%Z. +Proof. + intros. + case z. + simpl in |- *. + apply Zle_refl. + case p. + intro. + simpl in |- *. + apply Zle_refl. + intros. + simpl in |- *. + apply Zle_refl. + intros. + unfold Zabs at 2 in |- *. + unfold Zabs at 2 in |- *. + apply Zabs_8. + split. + apply Zplus_le_reg_l with (Zpos p1 - Zneg p0)%Z. + replace (Zpos p1 - Zneg p0 + - (Zpos p1 + Zpos p0))%Z with + (- (Zpos p0 + Zneg p0))%Z. + replace (Zpos p1 - Zneg p0 + (Zpos p1 + Zneg p0))%Z with (2 * Zpos p1)%Z. + replace (- (Zpos p0 + Zneg p0))%Z with 0%Z. + apply Zmult_gt_0_le_0_compat. + constructor. + apply Zlt_le_weak. + constructor. + rewrite <- Zopp_neg with p0. + ring. + ring. + ring. + apply Zplus_le_compat. + apply Zle_refl. + apply Zlt_le_weak. + constructor. + + case p. + simpl in |- *. + intro. + apply Zle_refl. + intros. + unfold Zabs at 2 in |- *. + unfold Zabs at 2 in |- *. + apply Zabs_8. + split. + apply Zplus_le_reg_l with (Zpos p1 + Zneg p0)%Z. + replace (Zpos p1 + Zneg p0 + - (Zpos p1 + Zpos p0))%Z with + (Zneg p0 - Zpos p0)%Z. + replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with 0%Z. + apply Zplus_le_reg_l with (Zpos p0). + replace (Zpos p0 + (Zneg p0 - Zpos p0))%Z with (Zneg p0). + simpl in |- *. + apply Zlt_le_weak. + constructor. + ring. + replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with + (Zpos p1 + Zneg p1 + (Zpos p0 + Zneg p0))%Z. + replace 0%Z with (0 + 0)%Z. + apply Zplus_eq_compat. + rewrite <- Zopp_neg with p1. + ring. + rewrite <- Zopp_neg with p0. + ring. + simpl in |- *. + constructor. + ring. + ring. + apply Zplus_le_compat. + apply Zlt_le_weak. + constructor. + apply Zle_refl. + intros. + simpl in |- *. + apply Zle_refl. +Qed. + +Lemma Zabs_neg : forall z : Z, (z <= 0)%Z -> Zabs z = (- z)%Z. +Proof. + intro. + case z. + simpl in |- *. + intro. + reflexivity. + intros. + apply False_ind. + apply H. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zle_Zabs: forall z, (z <= Zabs z)%Z. +Proof. + intros [|z|z]; simpl; auto with zarith; apply Zle_neg_pos. +Qed. + +Hint Resolve Zabs_1 Zabs_2 Zabs_3 Zabs_4 Zabs_5 Zabs_6 Zabs_7 Zabs_8 Zabs_9 + Zabs_10 Zabs_11 Zabs_12 Zabs_min Zabs_neg Zabs_mult Zabs_plus Zle_Zabs: zarith. + + +(*###########################################################################*) +(** Induction on Z *) +(*###########################################################################*) + +Lemma Zind : + forall (P : Z -> Prop) (p : Z), + P p -> + (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros P p. + intro. + intro. + cut (forall q : Z, (p <= q)%Z -> exists k : nat, q = (p + k)%Z). + intro. + cut (forall k : nat, P (p + k)%Z). + intro. + intros. + cut (exists k : nat, q = (p + Z_of_nat k)%Z). + intro. + case H4. + intros. + rewrite H5. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + ring_simplify (p + 0)%Z. + assumption. + replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (Z_of_nat 0). + ring_simplify (- p + (p + Z_of_nat k))%Z. + apply Znat.inj_le. + apply le_O_n. + ring_simplify; auto with arith. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + ring. + intros. + cut (exists k : nat, (q - p)%Z = Z_of_nat k). + intro. + case H2. + intro k. + intros. + exists k. + apply Zplus_reg_l with (n := (- p)%Z). + replace (- p + q)%Z with (q - p)%Z. + rewrite H3. + ring. + ring. + apply Z_of_nat_complete. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zrec : + forall (P : Z -> Set) (p : Z), + P p -> + (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros F p. + intro. + intro. + cut (forall q : Z, (p <= q)%Z -> {k : nat | q = (p + k)%Z}). + intro. + cut (forall k : nat, F (p + k)%Z). + intro. + intros. + cut {k : nat | q = (p + Z_of_nat k)%Z}. + intro. + case H4. + intros. + rewrite e. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + rewrite Zplus_0_r. + assumption. + replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (Z_of_nat 0). + replace (- p + (p + Z_of_nat k))%Z with (Z_of_nat k). + apply Znat.inj_le. + apply le_O_n. + rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. + rewrite Zplus_opp_l; reflexivity. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + apply Zplus_assoc_reverse. + intros. + cut {k : nat | (q - p)%Z = Z_of_nat k}. + intro H2. + case H2. + intro k. + intros. + exists k. + apply Zplus_reg_l with (n := (- p)%Z). + replace (- p + q)%Z with (q - p)%Z. + rewrite e. + rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. + unfold Zminus in |- *. + apply Zplus_comm. + apply Z_of_nat_complete_inf. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zrec_down : + forall (P : Z -> Set) (p : Z), + P p -> + (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) -> + forall q : Z, (q <= p)%Z -> P q. +Proof. + intros F p. + intro. + intro. + cut (forall q : Z, (q <= p)%Z -> {k : nat | q = (p - k)%Z}). + intro. + cut (forall k : nat, F (p - k)%Z). + intro. + intros. + cut {k : nat | q = (p - Z_of_nat k)%Z}. + intro. + case H4. + intros. + rewrite e. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + replace (p - 0)%Z with p. + assumption. + unfold Zminus in |- *. + unfold Zopp in |- *. + rewrite Zplus_0_r; reflexivity. + replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (- Z_of_nat 0)%Z. + replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z. + apply Zge_le. + apply Zge_opp. + apply Znat.inj_le. + apply le_O_n. + unfold Zminus in |- *; rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. + rewrite Zplus_opp_l; reflexivity. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + unfold Zminus at 1 2 in |- *. + rewrite Zplus_assoc_reverse. + rewrite <- Zopp_plus_distr. + reflexivity. + intros. + cut {k : nat | (p - q)%Z = Z_of_nat k}. + intro. + case H2. + intro k. + intros. + exists k. + apply Zopp_inj. + apply Zplus_reg_l with (n := p). + replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). + rewrite <- e. + reflexivity. + unfold Zminus in |- *. + rewrite Zopp_plus_distr. + rewrite Zplus_assoc. + rewrite Zplus_opp_r. + rewrite Zopp_involutive. + reflexivity. + apply Z_of_nat_complete_inf. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zind_down : + forall (P : Z -> Prop) (p : Z), + P p -> + (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) -> + forall q : Z, (q <= p)%Z -> P q. +Proof. + intros F p. + intro. + intro. + cut (forall q : Z, (q <= p)%Z -> exists k : nat, q = (p - k)%Z). + intro. + cut (forall k : nat, F (p - k)%Z). + intro. + intros. + cut (exists k : nat, q = (p - Z_of_nat k)%Z). + intro. + case H4. + intros x e. + rewrite e. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + replace (p - 0)%Z with p. + assumption. + ring. + replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (- Z_of_nat 0)%Z. + replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z. + apply Zge_le. + apply Zge_opp. + apply Znat.inj_le. + apply le_O_n. + ring. + ring_simplify; auto with arith. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + ring. + intros. + cut (exists k : nat, (p - q)%Z = Z_of_nat k). + intro. + case H2. + intro k. + intros. + exists k. + apply Zopp_inj. + apply Zplus_reg_l with (n := p). + replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). + rewrite <- H3. + ring. + ring. + apply Z_of_nat_complete. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zrec_wf : + forall (P : Z -> Set) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros P p WF_ind_step q Hq. + cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y). + intro. + apply (H (Zsucc q)). + apply Zle_le_succ. + assumption. + + split; [ assumption | exact (Zlt_succ q) ]. + + intros x0 Hx0; generalize Hx0; pattern x0 in |- *. + apply Zrec with (p := p). + intros. + absurd (p <= p)%Z. + apply Zgt_not_le. + apply Zgt_le_trans with (m := y). + apply Zlt_gt. + elim H. + intros. + assumption. + elim H. + intros. + assumption. + apply Zle_refl. + + intros. + apply WF_ind_step. + intros. + apply (H0 H). + split. + elim H2. + intros. + assumption. + apply Zlt_le_trans with y. + elim H2. + intros. + assumption. + apply Zgt_succ_le. + apply Zlt_gt. + elim H1. + intros. + unfold Zsucc in |- *. + assumption. + assumption. +Qed. + +Lemma Zrec_wf2 : + forall (q : Z) (P : Z -> Set) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + (p <= q)%Z -> P q. +Proof. + intros. + apply Zrec_wf with (p := p). + assumption. + assumption. +Qed. + +Lemma Zrec_wf_double : + forall (P : Z -> Z -> Set) (p0 q0 : Z), + (forall n m : Z, + (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) -> + (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) -> + forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q. +Proof. + intros P p0 q0 Hrec p. + intros. + generalize q H. + pattern p in |- *. + apply Zrec_wf with (p := p0). + intros p1 H1. + intros. + pattern q1 in |- *. + apply Zrec_wf with (p := q0). + intros q2 H3. + apply Hrec. + intros. + apply H1. + assumption. + assumption. + intros. + apply H3. + assumption. + assumption. + assumption. +Qed. + +Lemma Zind_wf : + forall (P : Z -> Prop) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros P p WF_ind_step q Hq. + cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y). + intro. + apply (H (Zsucc q)). + apply Zle_le_succ. + assumption. + + split; [ assumption | exact (Zlt_succ q) ]. + + intros x0 Hx0; generalize Hx0; pattern x0 in |- *. + apply Zind with (p := p). + intros. + absurd (p <= p)%Z. + apply Zgt_not_le. + apply Zgt_le_trans with (m := y). + apply Zlt_gt. + elim H. + intros. + assumption. + elim H. + intros. + assumption. + apply Zle_refl. + + intros. + apply WF_ind_step. + intros. + apply (H0 H). + split. + elim H2. + intros. + assumption. + apply Zlt_le_trans with y. + elim H2. + intros. + assumption. + apply Zgt_succ_le. + apply Zlt_gt. + elim H1. + intros. + unfold Zsucc in |- *. + assumption. + assumption. +Qed. + +Lemma Zind_wf2 : + forall (q : Z) (P : Z -> Prop) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + (p <= q)%Z -> P q. +Proof. + intros. + apply Zind_wf with (p := p). + assumption. + assumption. +Qed. + +Lemma Zind_wf_double : + forall (P : Z -> Z -> Prop) (p0 q0 : Z), + (forall n m : Z, + (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) -> + (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) -> + forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q. +Proof. + intros P p0 q0 Hrec p. + intros. + generalize q H. + pattern p in |- *. + apply Zind_wf with (p := p0). + intros p1 H1. + intros. + pattern q1 in |- *. + apply Zind_wf with (p := q0). + intros q2 H3. + apply Hrec. + intros. + apply H1. + assumption. + assumption. + intros. + apply H3. + assumption. + assumption. + assumption. +Qed. + +(*###########################################################################*) +(** Properties of Zmax *) +(*###########################################################################*) + +Definition Zmax (n m : Z) := (n + m - Zmin n m)%Z. + +Lemma ZmaxSS : forall n m : Z, (Zmax n m + 1)%Z = Zmax (n + 1) (m + 1). +Proof. + intros. + unfold Zmax in |- *. + replace (Zmin (n + 1) (m + 1)) with (Zmin n m + 1)%Z. + ring. + symmetry in |- *. + change (Zmin (Zsucc n) (Zsucc m) = Zsucc (Zmin n m)) in |- *. + symmetry in |- *. + apply Zmin_SS. +Qed. + +Lemma Zle_max_l : forall n m : Z, (n <= Zmax n m)%Z. +Proof. + intros. + unfold Zmax in |- *. + apply Zplus_le_reg_l with (p := (- n + Zmin n m)%Z). + ring_simplify (- n + Zmin n m + n)%Z. + ring_simplify (- n + Zmin n m + (n + m - Zmin n m))%Z. + apply Zle_min_r. +Qed. + +Lemma Zle_max_r : forall n m : Z, (m <= Zmax n m)%Z. +Proof. + intros. + unfold Zmax in |- *. + apply Zplus_le_reg_l with (p := (- m + Zmin n m)%Z). + ring_simplify (- m + Zmin n m + m)%Z. + ring_simplify (- m + Zmin n m + (n + m - Zmin n m))%Z. + apply Zle_min_l. +Qed. + + +Lemma Zmin_or_informative : forall n m : Z, {Zmin n m = n} + {Zmin n m = m}. +Proof. + intros. + case (Z_lt_ge_dec n m). + unfold Zmin in |- *. + unfold Zlt in |- *. + intro z. + rewrite z. + left. + reflexivity. + intro. + cut ({(n > m)%Z} + {n = m :>Z}). + intro. + case H. + intros z0. + unfold Zmin in |- *. + unfold Zgt in z0. + rewrite z0. + right. + reflexivity. + intro. + rewrite e. + right. + apply Zmin_n_n. + cut ({(m < n)%Z} + {m = n :>Z}). + intro. + elim H. + intro. + left. + apply Zlt_gt. + assumption. + intro. + right. + symmetry in |- *. + assumption. + apply Z_le_lt_eq_dec. + apply Zge_le. + assumption. +Qed. + +Lemma Zmax_case : forall (n m : Z) (P : Z -> Set), P n -> P m -> P (Zmax n m). +Proof. + intros. + unfold Zmax in |- *. + case Zmin_or_informative with (n := n) (m := m). + intro. + rewrite e. + cut ((n + m - n)%Z = m). + intro. + rewrite H1. + assumption. + ring. + intro. + rewrite e. + cut ((n + m - m)%Z = n). + intro. + rewrite H1. + assumption. + ring. +Qed. + +Lemma Zmax_or_informative : forall n m : Z, {Zmax n m = n} + {Zmax n m = m}. +Proof. + intros. + unfold Zmax in |- *. + case Zmin_or_informative with (n := n) (m := m). + intro. + rewrite e. + right. + ring. + intro. + rewrite e. + left. + ring. +Qed. + +Lemma Zmax_n_n : forall n : Z, Zmax n n = n. +Proof. + intros. + unfold Zmax in |- *. + rewrite (Zmin_n_n n). + ring. +Qed. + +Hint Resolve ZmaxSS Zle_max_r Zle_max_l Zmax_n_n: zarith. + +(*###########################################################################*) +(** Properties of Arity *) +(*###########################################################################*) + +Lemma Zeven_S : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x + 1). +Proof. + exact Zeven.Zeven_Sn. +Qed. + +Lemma Zeven_pred : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x - 1). +Proof. + exact Zeven.Zeven_pred. +Qed. + +(* This lemma used to be useful since it was mentioned with an unnecessary premise + `x>=0` as Z_modulo_2 in ZArith, but the ZArith version has been fixed. *) + +Definition Z_modulo_2_always : + forall x : Z, {y : Z | x = (2 * y)%Z} + {y : Z | x = (2 * y + 1)%Z} := + Zeven.Z_modulo_2. + +(*###########################################################################*) +(** Properties of Zdiv *) +(*###########################################################################*) + +Lemma Z_div_mod_eq_2 : + forall a b : Z, (0 < b)%Z -> (b * (a / b))%Z = (a - a mod b)%Z. +Proof. + intros. + apply Zplus_minus_eq. + rewrite Zplus_comm. + apply Z_div_mod_eq. + Flip. +Qed. + +Lemma Z_div_le : + forall a b c : Z, (0 < c)%Z -> (b <= a)%Z -> (b / c <= a / c)%Z. +Proof. + intros. + apply Zge_le. + apply Z_div_ge; Flip; assumption. +Qed. + +Lemma Z_div_nonneg : + forall a b : Z, (0 < b)%Z -> (0 <= a)%Z -> (0 <= a / b)%Z. +Proof. + intros. + apply Zge_le. + apply Z_div_ge0; Flip; assumption. +Qed. + +Lemma Z_div_neg : forall a b : Z, (0 < b)%Z -> (a < 0)%Z -> (a / b < 0)%Z. +Proof. + intros. + rewrite (Z_div_mod_eq a b) in H0. + elim (Z_mod_lt a b). + intros H1 _. + apply Znot_ge_lt. + intro. + apply (Zlt_not_le (b * (a / b) + a mod b) 0 H0). + apply Zplus_le_0_compat. + apply Zmult_le_0_compat. + apply Zlt_le_weak; assumption. + Flip. + assumption. + Flip. + Flip. +Qed. + +Hint Resolve Z_div_mod_eq_2 Z_div_le Z_div_nonneg Z_div_neg: zarith. + +(*###########################################################################*) +(** Properties of Zpower *) +(*###########################################################################*) + +Lemma Zpower_1 : forall a : Z, (a ^ 1)%Z = a. +Proof. + intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *; + auto with zarith. +Qed. + +Lemma Zpower_2 : forall a : Z, (a ^ 2)%Z = (a * a)%Z. +Proof. + intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *; + ring. +Qed. + +Hint Resolve Zpower_1 Zpower_2: zarith. diff --git a/test-suite/micromega/example.v b/test-suite/micromega/example.v index d648c2e4..25e4a09f 100644 --- a/test-suite/micromega/example.v +++ b/test-suite/micromega/example.v @@ -2,13 +2,12 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) (* *) (************************************************************************) Require Import ZArith. Require Import Psatz. -Require Import Ring_normalize. Open Scope Z_scope. Require Import ZMicromega. Require Import VarMap. @@ -23,7 +22,7 @@ Proof. Qed. -(* From Laurent Théry *) +(* From Laurent Théry *) Lemma some_pol : forall x, 4 * x ^ 2 + 3 * x + 2 >= 0. Proof. diff --git a/test-suite/micromega/heap3_vcgen_25.v b/test-suite/micromega/heap3_vcgen_25.v index efb5c7fd..00522f50 100644 --- a/test-suite/micromega/heap3_vcgen_25.v +++ b/test-suite/micromega/heap3_vcgen_25.v @@ -7,7 +7,7 @@ (************************************************************************) Require Import ZArith. -Require Import Psatz. +Require Import Lia. Open Scope Z_scope. diff --git a/test-suite/micromega/qexample.v b/test-suite/micromega/qexample.v index 76dc52e6..47e6005b 100644 --- a/test-suite/micromega/qexample.v +++ b/test-suite/micromega/qexample.v @@ -8,7 +8,6 @@ Require Import Psatz. Require Import QArith. -Require Import Ring_normalize. Lemma plus_minus : forall x y, 0 == x + y -> 0 == x -y -> 0 == x /\ 0 == y. diff --git a/test-suite/micromega/rexample.v b/test-suite/micromega/rexample.v index 9bb9dacc..2eed7e95 100644 --- a/test-suite/micromega/rexample.v +++ b/test-suite/micromega/rexample.v @@ -8,7 +8,6 @@ Require Import Psatz. Require Import Reals. -Require Import Ring_normalize. Open Scope R_scope. diff --git a/test-suite/micromega/zomicron.v b/test-suite/micromega/zomicron.v index 3b246023..0ec1dbfb 100644 --- a/test-suite/micromega/zomicron.v +++ b/test-suite/micromega/zomicron.v @@ -1,5 +1,5 @@ Require Import ZArith. -Require Import Psatz. +Require Import Lia. Open Scope Z_scope. Lemma two_x_eq_1 : forall x, 2 * x = 1 -> False. diff --git a/test-suite/misc/berardi_test.v b/test-suite/misc/berardi_test.v index 9f01c565..219686b9 100644 --- a/test-suite/misc/berardi_test.v +++ b/test-suite/misc/berardi_test.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* false - | cons e' s' => ifte (E.eq_dec e e') true (find e s') + | nil _ => false + | cons _ e' s' => ifte (E.eq_dec e e') true (find e s') end. Definition find_empty_false (e : elt) := refl_equal false. diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index 7c9b1e27..629a1ab6 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -1,94 +1,110 @@ -minus : nat -> nat -> nat +Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] -The simpl tactic unfolds minus avoiding to expose match constructs -minus is transparent -Expands to: Constant Coq.Init.Peano.minus -minus : nat -> nat -> nat +The reduction tactics unfold Nat.sub but avoid exposing match constructs +Nat.sub is transparent +Expands to: Constant Coq.Init.Nat.sub +Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] -The simpl tactic unfolds minus when applied to 1 argument - avoiding to expose match constructs -minus is transparent -Expands to: Constant Coq.Init.Peano.minus -minus : nat -> nat -> nat +The reduction tactics unfold Nat.sub when applied to 1 argument + but avoid exposing match constructs +Nat.sub is transparent +Expands to: Constant Coq.Init.Nat.sub +Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] -The simpl tactic unfolds minus +The reduction tactics unfold Nat.sub when the 1st argument evaluates to a constructor and - when applied to 1 argument avoiding to expose match constructs -minus is transparent -Expands to: Constant Coq.Init.Peano.minus -minus : nat -> nat -> nat + when applied to 1 argument but avoid exposing match constructs +Nat.sub is transparent +Expands to: Constant Coq.Init.Nat.sub +Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] -The simpl tactic unfolds minus - when the 1st and 2nd arguments evaluate to a constructor and - when applied to 2 arguments -minus is transparent -Expands to: Constant Coq.Init.Peano.minus -minus : nat -> nat -> nat +The reduction tactics unfold Nat.sub when the 1st and + 2nd arguments evaluate to a constructor and when applied to 2 arguments +Nat.sub is transparent +Expands to: Constant Coq.Init.Nat.sub +Nat.sub : nat -> nat -> nat +Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] -The simpl tactic unfolds minus - when the 1st and 2nd arguments evaluate to a constructor -minus is transparent -Expands to: Constant Coq.Init.Peano.minus +The reduction tactics unfold Nat.sub when the 1st and + 2nd arguments evaluate to a constructor +Nat.sub is transparent +Expands to: Constant Coq.Init.Nat.sub pf : forall D1 C1 : Type, (D1 -> C1) -> forall D2 C2 : Type, (D2 -> C2) -> D1 * D2 -> C1 * C2 +pf is not universe polymorphic Arguments D2, C2 are implicit Arguments D1, C1 are implicit and maximally inserted Argument scopes are [foo_scope type_scope _ _ _ _ _] -The simpl tactic never unfolds pf +The reduction tactics never unfold pf pf is transparent Expands to: Constant Top.pf fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C +fcomp is not universe polymorphic Arguments A, B, C are implicit and maximally inserted Argument scopes are [type_scope type_scope type_scope _ _ _] -The simpl tactic unfolds fcomp when applied to 6 arguments +The reduction tactics unfold fcomp when applied to 6 arguments fcomp is transparent Expands to: Constant Top.fcomp volatile : nat -> nat +volatile is not universe polymorphic Argument scope is [nat_scope] -The simpl tactic always unfolds volatile +The reduction tactics always unfold volatile volatile is transparent Expands to: Constant Top.volatile f : T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic Argument scopes are [_ _ nat_scope _ nat_scope] f is transparent Expands to: Constant Top.S1.S2.f f : T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic Argument scopes are [_ _ nat_scope _ nat_scope] -The simpl tactic unfolds f - when the 3rd, 4th and 5th arguments evaluate to a constructor +The reduction tactics unfold f when the 3rd, 4th and + 5th arguments evaluate to a constructor f is transparent Expands to: Constant Top.S1.S2.f f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic Argument T2 is implicit Argument scopes are [type_scope _ _ nat_scope _ nat_scope] -The simpl tactic unfolds f - when the 4th, 5th and 6th arguments evaluate to a constructor +The reduction tactics unfold f when the 4th, 5th and + 6th arguments evaluate to a constructor f is transparent Expands to: Constant Top.S1.f f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat +f is not universe polymorphic Arguments T1, T2 are implicit Argument scopes are [type_scope type_scope _ _ nat_scope _ nat_scope] -The simpl tactic unfolds f - when the 5th, 6th and 7th arguments evaluate to a constructor +The reduction tactics unfold f when the 5th, 6th and + 7th arguments evaluate to a constructor f is transparent Expands to: Constant Top.f + = forall v : unit, f 0 0 5 v 3 = 2 + : Prop + = 2 = 2 + : Prop f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat -The simpl tactic unfolds f - when the 5th, 6th and 7th arguments evaluate to a constructor +f is not universe polymorphic +The reduction tactics unfold f when the 5th, 6th and + 7th arguments evaluate to a constructor f is transparent Expands to: Constant Top.f forall w : r, w 3 true = tt diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v index 573cfdab..05eeaac6 100644 --- a/test-suite/output/Arguments.v +++ b/test-suite/output/Arguments.v @@ -1,13 +1,13 @@ -Arguments minus n m : simpl nomatch. -About minus. -Arguments minus n / m : simpl nomatch. -About minus. -Arguments minus !n / m : simpl nomatch. -About minus. -Arguments minus !n !m /. -About minus. -Arguments minus !n !m. -About minus. +Arguments Nat.sub n m : simpl nomatch. +About Nat.sub. +Arguments Nat.sub n / m : simpl nomatch. +About Nat.sub. +Arguments Nat.sub !n / m : simpl nomatch. +About Nat.sub. +Arguments Nat.sub !n !m /. +About Nat.sub. +Arguments Nat.sub !n !m. +About Nat.sub. Definition pf (D1 C1 : Type) (f : D1 -> C1) (D2 C2 : Type) (g : D2 -> C2) := fun x => (f (fst x), g (snd x)). Delimit Scope foo_scope with F. @@ -36,13 +36,15 @@ End S2. About f. End S1. About f. +Eval cbn in forall v, f 0 0 5 v 3 = 2. +Eval cbn in f 0 0 5 tt 3 = 2. Arguments f : clear implicits and scopes. About f. Record r := { pi :> nat -> bool -> unit }. Notation "$" := 3 (only parsing) : foo_scope. Notation "$" := true (only parsing) : bar_scope. Delimit Scope bar_scope with B. -Arguments pi _ _%F _%B. +Arguments pi _ _%F _%B. Check (forall w : r, pi w $ $ = tt). Fail Check (forall w : r, w $ $ = tt). Axiom w : r. diff --git a/test-suite/output/ArgumentsScope.out b/test-suite/output/ArgumentsScope.out index 756e8ede..71d5fc78 100644 --- a/test-suite/output/ArgumentsScope.out +++ b/test-suite/output/ArgumentsScope.out @@ -1,61 +1,70 @@ a : bool -> bool +a is not universe polymorphic Argument scope is [bool_scope] Expands to: Variable a b : bool -> bool +b is not universe polymorphic Argument scope is [bool_scope] Expands to: Variable b negb'' : bool -> bool +negb'' is not universe polymorphic Argument scope is [bool_scope] negb'' is transparent Expands to: Constant Top.A.B.negb'' negb' : bool -> bool +negb' is not universe polymorphic Argument scope is [bool_scope] negb' is transparent Expands to: Constant Top.A.negb' negb : bool -> bool +negb is not universe polymorphic Argument scope is [bool_scope] negb is transparent Expands to: Constant Coq.Init.Datatypes.negb -Warning: Arguments Scope is deprecated; use Arguments instead -Warning: Arguments Scope is deprecated; use Arguments instead -Warning: Arguments Scope is deprecated; use Arguments instead -Warning: Arguments Scope is deprecated; use Arguments instead -Warning: Arguments Scope is deprecated; use Arguments instead a : bool -> bool +a is not universe polymorphic Expands to: Variable a b : bool -> bool +b is not universe polymorphic Expands to: Variable b negb : bool -> bool +negb is not universe polymorphic negb is transparent Expands to: Constant Coq.Init.Datatypes.negb negb' : bool -> bool +negb' is not universe polymorphic negb' is transparent Expands to: Constant Top.A.negb' negb'' : bool -> bool +negb'' is not universe polymorphic negb'' is transparent Expands to: Constant Top.A.B.negb'' a : bool -> bool +a is not universe polymorphic Expands to: Variable a negb : bool -> bool +negb is not universe polymorphic negb is transparent Expands to: Constant Coq.Init.Datatypes.negb negb' : bool -> bool +negb' is not universe polymorphic negb' is transparent Expands to: Constant Top.negb' negb'' : bool -> bool +negb'' is not universe polymorphic negb'' is transparent Expands to: Constant Top.negb'' diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 17c80d13..c29f5649 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -6,7 +6,7 @@ The command has indeed failed with message: Argument A renamed to T. @eq_refl : forall (B : Type) (y : B), y = y -eq_refl +@eq_refl nat : forall x : nat, x = x Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x @@ -20,6 +20,7 @@ For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] eq_refl : forall (A : Type) (x : A), x = x +eq_refl is not universe polymorphic Arguments are renamed to B, y When applied to no arguments: Arguments B, y are implicit and maximally inserted @@ -35,6 +36,7 @@ For myEq: Argument scopes are [type_scope _ _] For myrefl: Argument scopes are [type_scope _ _] myrefl : forall (B : Type) (x : A), B -> myEq B x x +myrefl is not universe polymorphic Arguments are renamed to C, x, _ Argument C is implicit and maximally inserted Argument scopes are [type_scope _ _] @@ -47,19 +49,21 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat +myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] myplus : forall T : Type, T -> nat -> nat -> nat +myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] -The simpl tactic unfolds myplus - when the 2nd and 3rd arguments evaluate to a constructor +The reduction tactics unfold myplus when the 2nd and + 3rd arguments evaluate to a constructor myplus is transparent Expands to: Constant Top.Test1.myplus -myplus +@myplus : forall Z : Type, Z -> nat -> nat -> nat Inductive myEq (A B : Type) (x : A) : A -> Prop := myrefl : B -> myEq A B x x @@ -70,6 +74,7 @@ For myEq: Argument scopes are [type_scope type_scope _ _] For myrefl: Argument scopes are [type_scope type_scope _ _] myrefl : forall (A B : Type) (x : A), B -> myEq A B x x +myrefl is not universe polymorphic Arguments are renamed to A, C, x, _ Argument C is implicit and maximally inserted Argument scopes are [type_scope type_scope _ _] @@ -84,19 +89,21 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat +myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] myplus : forall T : Type, T -> nat -> nat -> nat +myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] -The simpl tactic unfolds myplus - when the 2nd and 3rd arguments evaluate to a constructor +The reduction tactics unfold myplus when the 2nd and + 3rd arguments evaluate to a constructor myplus is transparent Expands to: Constant Top.myplus -myplus +@myplus : forall Z : Type, Z -> nat -> nat -> nat The command has indeed failed with message: => Error: All arguments lists must declare the same names. diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 1ec02c56..d5903483 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -2,13 +2,23 @@ t_rect = fun (P : t -> Type) (f : let x := t in forall x0 : x, P x0 -> P (k x0)) => fix F (t : t) : P t := match t as t0 return (P t0) with - | k _ x0 => f x0 (F x0) + | @k _ x0 => f x0 (F x0) end : forall P : t -> Type, (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t + +t_rect is not universe polymorphic + = fun d : TT => match d with + | @CTT _ _ b => b + end + : TT -> 0 = 0 + = fun d : TT => match d with + | @CTT _ _ b => b + end + : TT -> 0 = 0 proj = fun (x y : nat) (P : nat -> Type) (def : P x) (prf : P y) => -match eq_nat_dec x y with +match Nat.eq_dec x y with | left eqprf => match eqprf in (_ = z) return (P z) with | eq_refl => def end @@ -16,6 +26,7 @@ match eq_nat_dec x y with end : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y +proj is not universe polymorphic Argument scopes are [nat_scope nat_scope _ _ _] foo = fix foo (A : Type) (l : list A) {struct l} : option A := @@ -26,6 +37,29 @@ fix foo (A : Type) (l : list A) {struct l} : option A := end : forall A : Type, list A -> option A +foo is not universe polymorphic Argument scopes are [type_scope list_scope] +uncast = +fun (A : Type) (x : I A) => match x with + | x0 <: _ => x0 + end + : forall A : Type, I A -> A + +uncast is not universe polymorphic +Argument scopes are [type_scope _] foo' = if A 0 then true else false : bool + +foo' is not universe polymorphic +f = +fun H : B => +match H with +| AC x => + (let b0 := b in + if b0 as b return (P b -> True) + then fun _ : P true => Logic.I + else fun _ : P false => Logic.I) x +end + : B -> True + +f is not universe polymorphic diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index b6337586..4116a5eb 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -5,6 +5,11 @@ Inductive t : Set := Print t_rect. +Record TT : Type := CTT { f1 := 0 : nat; f2: nat; f3 : f1=f1 }. + +Eval cbv in fun d:TT => match d return 0 = 0 with CTT a _ b => b end. +Eval lazy in fun d:TT => match d return 0 = 0 with CTT a _ b => b end. + (* Do not contract nested patterns with dependent return type *) (* see bug #1699 *) @@ -34,6 +39,18 @@ Fixpoint foo (A:Type) (l:list A) : option A := Print foo. +(* Accept and use notation with binded parameters *) + +Inductive I (A: Type) : Type := C : A -> I A. +Notation "x <: T" := (C T x) (at level 38). + +Definition uncast A (x : I A) := +match x with + | x <: _ => x +end. + +Print uncast. + (* Do not duplicate the matched term *) Axiom A : nat -> bool. @@ -46,3 +63,17 @@ Definition foo' := Print foo'. +(* Was bug #3293 (eta-expansion at "match" printing time was failing because + of let-in's interpreted as being part of the expansion) *) + +Variable b : bool. +Variable P : bool -> Prop. +Inductive B : Prop := AC : P b -> B. +Definition f : B -> True. + +Proof. +intros []. +destruct b as [|] ; intros _ ; exact Logic.I. +Defined. + +Print f. diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out index f61b7ecf..bcc37b63 100644 --- a/test-suite/output/Errors.out +++ b/test-suite/output/Errors.out @@ -1,2 +1,7 @@ The command has indeed failed with message: => Error: The field t is missing in Top.M. +The command has indeed failed with message: +=> Error: Unable to unify "nat" with "True". +The command has indeed failed with message: +=> In nested Ltac calls to "f" and "apply x", last call failed. +Error: Unable to unify "nat" with "True". diff --git a/test-suite/output/Errors.v b/test-suite/output/Errors.v index 75763f3b..352c8738 100644 --- a/test-suite/output/Errors.v +++ b/test-suite/output/Errors.v @@ -7,3 +7,12 @@ Parameter t:Type. End S. Module M : S. Fail End M. + +(* A simple check of how Ltac trace are used or not *) +(* Unfortunately, cannot test error location... *) + +Ltac f x := apply x. +Goal True. +Fail simpl; apply 0. +Fail simpl; f 0. +Abort. diff --git a/test-suite/output/Existentials.out b/test-suite/output/Existentials.out index 2f756cbb..483a9ea7 100644 --- a/test-suite/output/Existentials.out +++ b/test-suite/output/Existentials.out @@ -1,3 +1,5 @@ -Existential 1 = ?10 : [q : nat n : nat m : nat |- n = ?9] -Existential 2 = ?9 : [n : nat m : nat |- nat] -Existential 3 = ?7 : [p : nat q := S p : nat n : nat m : nat |- ?9 = m] +Existential 1 = +?Goal0 : [p : nat q := S p : nat n : nat m : nat |- ?y = m] +Existential 2 = +?y : [p : nat q := S p : nat n : nat m : nat |- nat] (p, q cannot be used) +Existential 3 = ?e : [q : nat n : nat m : nat |- n = ?y] diff --git a/test-suite/output/Extraction_matchs_2413.v b/test-suite/output/Extraction_matchs_2413.v index f5610efc..6c514b16 100644 --- a/test-suite/output/Extraction_matchs_2413.v +++ b/test-suite/output/Extraction_matchs_2413.v @@ -22,8 +22,8 @@ Inductive hole (A:Set) : Set := Hole | Hole2. Definition wrong_id (A B : Set) (x:hole A) : hole B := match x with - | Hole => @Hole _ - | Hole2 => @Hole2 _ + | Hole _ => @Hole _ + | Hole2 _ => @Hole2 _ end. Extraction wrong_id. (** should _not_ be optimized as an identity *) @@ -114,9 +114,9 @@ Definition decode_cond_mode (mode : Type) (f : word -> decoder_result mode) | Some oc => match f w with | DecInst i => DecInst (g i oc) - | DecError m => @DecError inst m - | DecUndefined => @DecUndefined inst - | DecUnpredictable => @DecUnpredictable inst + | DecError _ m => @DecError inst m + | DecUndefined _ => @DecUndefined inst + | DecUnpredictable _ => @DecUnpredictable inst end | None => @DecUndefined inst end. diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out index 3b65003c..0b0f501f 100644 --- a/test-suite/output/Implicit.out +++ b/test-suite/output/Implicit.out @@ -5,6 +5,7 @@ ex_intro (P:=fun _ : nat => True) (x:=0) I d2 = fun x : nat => d1 (y:=x) : forall x x0 : nat, x0 = x -> x0 = x +d2 is not universe polymorphic Arguments x, x0 are implicit Argument scopes are [nat_scope nat_scope _] map id (1 :: nil) diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out index 55017469..bbfd3405 100644 --- a/test-suite/output/InitSyntax.out +++ b/test-suite/output/InitSyntax.out @@ -1,5 +1,5 @@ Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := - exist2 : forall x : A, P x -> Q x -> {x | P x & Q x} + exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x} For sig2: Argument A is implicit For exist2: Argument A is implicit diff --git a/test-suite/output/Intuition.out b/test-suite/output/Intuition.out index 5831c9f4..e99d9fde 100644 --- a/test-suite/output/Intuition.out +++ b/test-suite/output/Intuition.out @@ -1,7 +1,6 @@ 1 subgoal - m : Z - n : Z + m, n : Z H : (m >= n)%Z ============================ (m >= m)%Z diff --git a/test-suite/output/Match_subterm.out b/test-suite/output/Match_subterm.out index 951a98db..c99c8905 100644 --- a/test-suite/output/Match_subterm.out +++ b/test-suite/output/Match_subterm.out @@ -1,5 +1,7 @@ (0 = 1) +(eq 0) eq +@eq nat 0 1 diff --git a/test-suite/output/Nametab.out b/test-suite/output/Nametab.out index b1883ec0..c11621d7 100644 --- a/test-suite/output/Nametab.out +++ b/test-suite/output/Nametab.out @@ -7,15 +7,15 @@ Constant Top.Q.N.K.foo Constant Top.Q.N.K.foo Constant Top.Q.N.K.foo (shorter name to refer to it in current context is Q.N.K.foo) -No module is referred to by basename K -No module is referred to by name N.K +Module Top.Q.N.K (shorter name to refer to it in current context is Q.N.K) +Module Top.Q.N.K (shorter name to refer to it in current context is Q.N.K) Module Top.Q.N.K -Module Top.Q.N.K -No module is referred to by basename N -Module Top.Q.N +Module Top.Q.N.K (shorter name to refer to it in current context is Q.N.K) +Module Top.Q.N (shorter name to refer to it in current context is Q.N) Module Top.Q.N +Module Top.Q.N (shorter name to refer to it in current context is Q.N) Module Top.Q -Module Top.Q +Module Top.Q (shorter name to refer to it in current context is Q) Constant Top.Q.N.K.foo (shorter name to refer to it in current context is K.foo) Constant Top.Q.N.K.foo @@ -26,11 +26,11 @@ Constant Top.Q.N.K.foo Constant Top.Q.N.K.foo (shorter name to refer to it in current context is K.foo) Module Top.Q.N.K -No module is referred to by name N.K -Module Top.Q.N.K -Module Top.Q.N.K -No module is referred to by basename N -Module Top.Q.N +Module Top.Q.N.K (shorter name to refer to it in current context is K) +Module Top.Q.N.K (shorter name to refer to it in current context is K) +Module Top.Q.N.K (shorter name to refer to it in current context is K) +Module Top.Q.N (shorter name to refer to it in current context is Q.N) Module Top.Q.N +Module Top.Q.N (shorter name to refer to it in current context is Q.N) Module Top.Q -Module Top.Q +Module Top.Q (shorter name to refer to it in current context is Q) diff --git a/test-suite/output/Naming.out b/test-suite/output/Naming.out index df510063..f0d2562e 100644 --- a/test-suite/output/Naming.out +++ b/test-suite/output/Naming.out @@ -6,12 +6,8 @@ (forall x2 x5 : nat, x2 + x1 = x4 + x5) -> x + x1 = x4 + x0 1 subgoal - x3 : nat - x : nat - x1 : nat - x4 : nat - x0 : nat - H : forall x5 x6 : nat, x5 + x1 = x4 + x6 + x3, x, x1, x4, x0 : nat + H : forall x x3 : nat, x + x1 = x4 + x3 ============================ x + x1 = x4 + x0 1 subgoal @@ -33,11 +29,7 @@ forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x 1 subgoal - x3 : nat - x : nat - x1 : nat - x4 : nat - x0 : nat + x3, x, x1, x4, x0 : nat ============================ (forall x2 x5 : nat, x2 + x1 = x4 + x5 -> @@ -46,38 +38,26 @@ forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x 1 subgoal - x3 : nat - x : nat - x1 : nat - x4 : nat - x0 : nat - H : forall x5 x6 : nat, - x5 + x1 = x4 + x6 -> - forall x7 x8 x9 S : nat, x7 + S = x8 + x9 + (Datatypes.S x5 + x1) + x3, x, x1, x4, x0 : nat + H : forall x x3 : nat, + x + x1 = x4 + x3 -> + forall x0 x4 x5 S0 : nat, x0 + S0 = x4 + x5 + (S x + x1) H0 : x + x1 = x4 + x0 ============================ forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x 1 subgoal - x3 : nat - x : nat - x1 : nat - x4 : nat - x0 : nat - H : forall x5 x6 : nat, - x5 + x1 = x4 + x6 -> - forall x7 x8 x9 S : nat, x7 + S = x8 + x9 + (Datatypes.S x5 + x1) + x3, x, x1, x4, x0 : nat + H : forall x x3 : nat, + x + x1 = x4 + x3 -> + forall x0 x4 x5 S0 : nat, x0 + S0 = x4 + x5 + (Datatypes.S x + x1) H0 : x + x1 = x4 + x0 - x5 : nat - x6 : nat - x7 : nat - S : nat + x5, x6, x7, S : nat ============================ x5 + S = x6 + x7 + Datatypes.S x 1 subgoal - x3 : nat - a : nat - H : a = 0 -> forall a0 : nat, a0 = 0 + x3, a : nat + H : a = 0 -> forall a : nat, a = 0 ============================ a = 0 diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 66307236..60ee72b3 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -2,23 +2,21 @@ true ? 0; 1 : nat if true as x return (x ? nat; bool) then 0 else true : nat -Identifier 'proj1' now a keyword fun e : nat * nat => proj1 e : nat * nat -> nat -Identifier 'decomp' now a keyword decomp (true, true) as t, u in (t, u) : bool * bool -!(0 = 0) +! (0 = 0) : Prop forall n : nat, n = 0 : Prop -!(0 = 0) +! (0 = 0) : Prop -forall n : nat, #(n = n) +forall n : nat, # (n = n) : Prop -forall n n0 : nat, ##(n = n0) +forall n n0 : nat, ## (n = n0) : Prop -forall n n0 : nat, ###(n = n0) +forall n n0 : nat, ### (n = n0) : Prop 3 + 3 : Z @@ -28,21 +26,17 @@ forall n n0 : nat, ###(n = n0) : list nat (1; 2, 4) : nat * nat * nat -Identifier 'ifzero' now a keyword ifzero 3 : bool -Identifier 'pred' now a keyword pred 3 : nat fun n : nat => pred n : nat -> nat fun n : nat => pred n : nat -> nat -Identifier 'ifn' now a keyword -Identifier 'is' now a keyword fun x : nat => ifn x is succ n then n else 0 : nat -> nat -1- +1 - : bool -4 : Z @@ -50,14 +44,12 @@ The command has indeed failed with message: => Error: x should not be bound in a recursive pattern of the right-hand side. The command has indeed failed with message: => Error: in the right-hand side, y and z should appear in - term position as part of a recursive pattern. +term position as part of a recursive pattern. The command has indeed failed with message: => Error: The reference w was not found in the current environment. The command has indeed failed with message: -=> Error: x is unbound in the right-hand side. -The command has indeed failed with message: => Error: in the right-hand side, y and z should appear in - term position as part of a recursive pattern. +term position as part of a recursive pattern. The command has indeed failed with message: => Error: z is expected to occur in binding position in the right-hand side. The command has indeed failed with message: @@ -80,7 +72,6 @@ Nil : forall A : Type, list A NIL:list nat : list nat -Identifier 'I' now a keyword (false && I 3)%bool /\ I 6 : Prop [|1, 2, 3; 4, 5, 6|] @@ -89,11 +80,11 @@ Identifier 'I' now a keyword : Z * Z * (Z * Z) * (Z * Z) * (Z * bool * (Z * bool) * (Z * bool)) fun f : Z -> Z -> Z -> Z => {|f; 0; 1; 2|}:Z : (Z -> Z -> Z -> Z) -> Z -plus +Init.Nat.add : nat -> nat -> nat S : nat -> nat -mult +Init.Nat.mul : nat -> nat -> nat le : nat -> nat -> Prop @@ -101,7 +92,7 @@ plus : nat -> nat -> nat succ : nat -> nat -mult +Init.Nat.mul : nat -> nat -> nat le : nat -> nat -> Prop @@ -116,18 +107,24 @@ fun x : option Z => match x with end : option Z -> Z fun x : option Z => match x with - | SOME3 x0 => x0 - | NONE3 => 0 + | SOME2 x0 => x0 + | NONE2 => 0 end : option Z -> Z +fun x : list ?T1 => match x with + | NIL => NONE2 + | (_ :') t => SOME2 t + end + : list ?T1 -> option (list ?T1) +where +?T1 : [x : list ?T1 x1 : list ?T1 x0 := x1 : list ?T1 |- Type] (x, x1, + x0 cannot be used) s : s -Identifier 'foo' now a keyword 10 : nat fun _ : nat => 9 : nat -> nat -Identifier 'ONE' now a keyword fun (x : nat) (p : x = x) => match p with | ONE => ONE end = p diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index 612b5325..adba688e 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -68,7 +68,7 @@ Coercion Zpos: nat >-> znat. Delimit Scope znat_scope with znat. Open Scope znat_scope. -Variable addz : znat -> znat -> znat. +Parameter addz : znat -> znat -> znat. Notation "z1 + z2" := (addz z1 z2) : znat_scope. (* Check that "3+3", where 3 is in nat and the coercion to znat is implicit, @@ -133,7 +133,8 @@ Fail Notation "( x , y , .. , z )" := (pair x (pair y z)). Fail Notation "( x , y , .. , z )" := (pair x .. (pair y w) ..). (* Right-unbound variable *) -Fail Notation "( x , y , .. , z )" := (pair y .. (pair z 0) ..). +(* Now allowed with an only parsing restriction *) +Notation "( x , y , .. , z )" := (pair y .. (pair z 0) ..). (* Not the right kind of recursive pattern *) Fail Notation "( x , y , .. , z )" := (ex (fun z => .. (ex (fun y => x)) ..)). @@ -244,7 +245,11 @@ Check (fun x => match x with SOME2 x => x | NONE2 => 0 end). Notation NONE3 := @None. Notation SOME3 := @Some. -Check (fun x => match x with SOME3 x => x | NONE3 => 0 end). +Check (fun x => match x with SOME3 _ x => x | NONE3 _ => 0 end). + +Notation "a :'" := (cons a) (at level 12). + +Check (fun x => match x with | nil => NONE | h :' t => SOME3 _ t end). (* Check correct matching of "Type" in notations. Of course the notation denotes a term that will be reinterpreted with a different @@ -275,3 +280,4 @@ Check fun (x:nat) (p : x=x) => match p with ONE => ONE end = p. Notation "1" := eq_refl. Check fun (x:nat) (p : x=x) => match p with 1 => 1 end = p. + diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out index cf45025e..58ec1de5 100644 --- a/test-suite/output/Notations2.out +++ b/test-suite/output/Notations2.out @@ -1,6 +1,6 @@ 2 3 : PAIR -2[+]3 +2 [+] 3 : nat forall (A : Set) (le : A -> A -> Prop) (x y : A), le x y \/ le y x : Prop @@ -10,7 +10,7 @@ end : nat let '(a, _, _) := (2, 3, 4) in a : nat -exists myx (y : bool), myx = y +exists myx y : bool, myx = y : Prop fun (P : nat -> nat -> Prop) (x : nat) => exists x0, P x x0 : (nat -> nat -> Prop) -> nat -> Prop @@ -24,7 +24,6 @@ let d := 2 in ∃ z : nat, let e := 3 in let f := 4 in x + y = z + d : Prop ∀ n p : nat, n + p = 0 : Prop -Identifier 'λ' now a keyword λ n p : nat, n + p = 0 : nat -> nat -> Prop λ (A : Type) (n p : A), n = p @@ -33,12 +32,11 @@ Identifier 'λ' now a keyword : Type -> Prop λ A : Type, ∀ n p : A, n = p : Type -> Prop -Identifier 'let'' now a keyword let' f (x y : nat) (a:=0) (z : nat) (_ : bool) := x + y + z + 1 in f 0 1 2 : bool -> nat λ (f : nat -> nat) (x : nat), f(x) + S(x) : (nat -> nat) -> nat -> nat -Notation plus2 n := (S (S n)) +Notation plus2 n := (S(S(n))) λ n : list(nat), match n with | nil => 2 diff --git a/test-suite/output/PrintAssumptions.out b/test-suite/output/PrintAssumptions.out index 23f33081..08df9150 100644 --- a/test-suite/output/PrintAssumptions.out +++ b/test-suite/output/PrintAssumptions.out @@ -2,6 +2,11 @@ Axioms: foo : nat Axioms: foo : nat +Fetching opaque proofs from disk for Coq.Numbers.NatInt.NZAdd +Fetching opaque proofs from disk for Coq.Arith.PeanoNat +Fetching opaque proofs from disk for Coq.Classes.Morphisms +Fetching opaque proofs from disk for Coq.Init.Logic +Fetching opaque proofs from disk for Coq.Numbers.NatInt.NZBase Axioms: extensionality : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index 598bb728..0457c860 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -1,16 +1,17 @@ -existT : forall (A : Type) (P : A -> Type) (x : A), P x -> sigT P +existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} +existT is template universe polymorphic Argument A is implicit Argument scopes are [type_scope _ _ _] Expands to: Constructor Coq.Init.Specif.existT Inductive sigT (A : Type) (P : A -> Type) : Type := - existT : forall x : A, P x -> sigT P + existT : forall x : A, P x -> {x : A & P x} For sigT: Argument A is implicit For existT: Argument A is implicit For sigT: Argument scopes are [type_scope type_scope] For existT: Argument scopes are [type_scope _ _ _] -existT : forall (A : Type) (P : A -> Type) (x : A), P x -> sigT P +existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} Argument A is implicit Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x @@ -24,6 +25,7 @@ For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] eq_refl : forall (A : Type) (x : A), x = x +eq_refl is not universe polymorphic When applied to no arguments: Arguments A, x are implicit and maximally inserted When applied to 1 argument: @@ -36,28 +38,30 @@ When applied to no arguments: Arguments A, x are implicit and maximally inserted When applied to 1 argument: Argument A is implicit -plus = -fix plus (n m : nat) {struct n} : nat := +Nat.add = +fix add (n m : nat) {struct n} : nat := match n with | 0 => m - | S p => S (plus p m) + | S p => S (add p m) end : nat -> nat -> nat +Nat.add is not universe polymorphic Argument scopes are [nat_scope nat_scope] -plus : nat -> nat -> nat +Nat.add : nat -> nat -> nat +Nat.add is not universe polymorphic Argument scopes are [nat_scope nat_scope] -plus is transparent -Expands to: Constant Coq.Init.Peano.plus -plus : nat -> nat -> nat +Nat.add is transparent +Expands to: Constant Coq.Init.Nat.add +Nat.add : nat -> nat -> nat plus_n_O : forall n : nat, n = n + 0 +plus_n_O is not universe polymorphic Argument scope is [nat_scope] plus_n_O is opaque Expands to: Constant Coq.Init.Peano.plus_n_O -Warning: Implicit Arguments is deprecated; use Arguments instead Inductive le (n : nat) : nat -> Prop := le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m @@ -76,12 +80,13 @@ For le_n: Argument scope is [nat_scope] For le_S: Argument scopes are [nat_scope nat_scope _] comparison : Set +comparison is not universe polymorphic Expands to: Inductive Coq.Init.Datatypes.comparison Inductive comparison : Set := Eq : comparison | Lt : comparison | Gt : comparison -Warning: Implicit Arguments is deprecated; use Arguments instead bar : foo +bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 @@ -89,12 +94,14 @@ Argument x is implicit and maximally inserted Expands to: Constant Top.bar *** [ bar : foo ] +bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 Argument x is implicit and maximally inserted bar : foo +bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 @@ -102,6 +109,7 @@ Argument x is implicit and maximally inserted Expands to: Constant Top.bar *** [ bar : foo ] +bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 @@ -109,7 +117,6 @@ Argument x is implicit and maximally inserted Module Coq.Init.Peano Notation existS2 := existT2 Expands to: Notation Coq.Init.Specif.existS2 -Warning: Implicit Arguments is deprecated; use Arguments instead Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq: Argument A is implicit and maximally inserted @@ -128,3 +135,15 @@ For eq_refl, when applied to 1 argument: Argument A is implicit and maximally inserted For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] +n:nat + +Hypothesis of the goal context. +h:(n <> newdef n) + +Hypothesis of the goal context. +g:(nat -> nat) + +Constant (let in) of the goal context. +h:(n <> newdef n) + +Hypothesis of the goal context. diff --git a/test-suite/output/PrintInfos.v b/test-suite/output/PrintInfos.v index deeb1f65..3c623346 100644 --- a/test-suite/output/PrintInfos.v +++ b/test-suite/output/PrintInfos.v @@ -6,9 +6,9 @@ Print eq_refl. About eq_refl. Print Implicit eq_refl. -Print plus. -About plus. -Print Implicit plus. +Print Nat.add. +About Nat.add. +Print Implicit Nat.add. About plus_n_O. @@ -39,3 +39,19 @@ Print eq_refl. Arguments eq_refl {A} {x}, {A} x. (* Test new syntax *) Print eq_refl. + + +Definition newdef := fun x:nat => x. + +Goal forall n:nat, n <> newdef n -> newdef n <> n -> False. + intros n h h'. + About n. (* search hypothesis *) + About h. (* search hypothesis *) +Abort. + +Goal forall n:nat, let g := newdef in n <> newdef n -> newdef n <> n -> False. + intros n g h h'. + About g. (* search hypothesis *) + About h. (* search hypothesis *) +Abort. + diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index 5d8f98ed..c17b285b 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -1,24 +1,108 @@ -le_S: forall n m : nat, n <= m -> n <= S m le_n: forall n : nat, n <= n -le_pred: forall n m : nat, n <= m -> pred n <= pred m +le_S: forall n m : nat, n <= m -> n <= S m +le_ind: + forall (n : nat) (P : nat -> Prop), + P n -> + (forall m : nat, n <= m -> P m -> P (S m)) -> + forall n0 : nat, n <= n0 -> P n0 +le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m le_S_n: forall n m : nat, S n <= S m -> n <= m -false: bool +le_0_n: forall n : nat, 0 <= n +le_n_S: forall n m : nat, n <= m -> S n <= S m +max_l: forall n m : nat, m <= n -> Nat.max n m = n +max_r: forall n m : nat, n <= m -> Nat.max n m = m +min_l: forall n m : nat, n <= m -> Nat.min n m = n +min_r: forall n m : nat, m <= n -> Nat.min n m = m true: bool -xorb: bool -> bool -> bool +false: bool +bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b +bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b +bool_rec: forall P : bool -> Set, P true -> P false -> forall b : bool, P b +andb: bool -> bool -> bool orb: bool -> bool -> bool -negb: bool -> bool implb: bool -> bool -> bool -andb: bool -> bool -> bool -pred_Sn: forall n : nat, n = pred (S n) -plus_n_Sm: forall n m : nat, S (n + m) = n + S m +xorb: bool -> bool -> bool +negb: bool -> bool +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true +andb_true_intro: + forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true +eq_true: bool -> Prop +eq_true_rect: + forall P : bool -> Type, P true -> forall b : bool, eq_true b -> P b +eq_true_ind: + forall P : bool -> Prop, P true -> forall b : bool, eq_true b -> P b +eq_true_rec: + forall P : bool -> Set, P true -> forall b : bool, eq_true b -> P b +is_true: bool -> Prop +eq_true_ind_r: + forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true +eq_true_rec_r: + forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true +eq_true_rect_r: + forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true +BoolSpec: Prop -> Prop -> bool -> Prop +BoolSpec_ind: + forall (P Q : Prop) (P0 : bool -> Prop), + (P -> P0 true) -> + (Q -> P0 false) -> forall b : bool, BoolSpec P Q b -> P0 b +Nat.eqb: nat -> nat -> bool +Nat.leb: nat -> nat -> bool +Nat.ltb: nat -> nat -> bool +Nat.even: nat -> bool +Nat.odd: nat -> bool +Nat.testbit: nat -> nat -> bool +Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat +bool_choice: + forall (S : Set) (R1 R2 : S -> Prop), + (forall x : S, {R1 x} + {R2 x}) -> + {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x} +eq_S: forall x y : nat, x = y -> S x = S y +f_equal_nat: forall (B : Type) (f : nat -> B) (x y : nat), x = y -> f x = f y +f_equal_pred: forall x y : nat, x = y -> Nat.pred x = Nat.pred y +pred_Sn: forall n : nat, n = Nat.pred (S n) +eq_add_S: forall n m : nat, S n = S m -> n = m +not_eq_S: forall n m : nat, n <> m -> S n <> S m +O_S: forall n : nat, 0 <> S n +n_Sn: forall n : nat, n <> S n +f_equal2_plus: + forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2 +f_equal2_nat: + forall (B : Type) (f : nat -> nat -> B) (x1 y1 x2 y2 : nat), + x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2 plus_n_O: forall n : nat, n = n + 0 -plus_Sn_m: forall n m : nat, S n + m = S (n + m) plus_O_n: forall n : nat, 0 + n = n -mult_n_Sm: forall n m : nat, n * m + n = n * S m +plus_n_Sm: forall n m : nat, S (n + m) = n + S m +plus_Sn_m: forall n m : nat, S n + m = S (n + m) +f_equal2_mult: + forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 * x2 = y1 * y2 mult_n_O: forall n : nat, 0 = n * 0 -min_r: forall n m : nat, m <= n -> min n m = m -min_l: forall n m : nat, n <= m -> min n m = n -max_r: forall n m : nat, n <= m -> max n m = m -max_l: forall n m : nat, m <= n -> max n m = n -eq_add_S: forall n m : nat, S n = S m -> n = m -eq_S: forall x y : nat, x = y -> S x = S y +mult_n_Sm: forall n m : nat, n * m + n = n * S m +max_l: forall n m : nat, m <= n -> Nat.max n m = n +max_r: forall n m : nat, n <= m -> Nat.max n m = m +min_l: forall n m : nat, n <= m -> Nat.min n m = n +min_r: forall n m : nat, m <= n -> Nat.min n m = m +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true +andb_true_intro: + forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true +bool_choice: + forall (S : Set) (R1 R2 : S -> Prop), + (forall x : S, {R1 x} + {R2 x}) -> + {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x} +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true +andb_true_intro: + forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true +h': newdef n <> n +h: n <> newdef n +h': newdef n <> n +h: n <> newdef n +h: n <> newdef n +h: n <> newdef n +h': ~ P n +h: P n +h': ~ P n +h: P n +h': ~ P n +h: P n +h: P n +h: P n diff --git a/test-suite/output/Search.v b/test-suite/output/Search.v index f1489f22..2a0f0b40 100644 --- a/test-suite/output/Search.v +++ b/test-suite/output/Search.v @@ -3,3 +3,27 @@ Search le. (* app nodes *) Search bool. (* no apps *) Search (@eq nat). (* complex pattern *) +Search (@eq _ _ true). +Search (@eq _ _ _) true -false. (* andb_prop *) +Search (@eq _ _ _) true -false "prop" -"intro". (* andb_prop *) + +Definition newdef := fun x:nat => x. + +Goal forall n:nat, n <> newdef n -> newdef n <> n -> False. + intros n h h'. + Search n. (* search hypothesis *) + Search newdef. (* search hypothesis *) + Search ( _ <> newdef _). (* search hypothesis, pattern *) + Search ( _ <> newdef _) -"h'". (* search hypothesis, pattern *) +Abort. + +Goal forall n (P:nat -> Prop), P n -> ~P n -> False. + intros n P h h'. + Search P. (* search hypothesis also for patterns *) + Search (P _). (* search hypothesis also for patterns *) + Search (P n). (* search hypothesis also for patterns *) + Search (P _) -"h'". (* search hypothesis also for patterns *) + Search (P _) -not. (* search hypothesis also for patterns *) + +Abort. + diff --git a/test-suite/output/SearchHead.out b/test-suite/output/SearchHead.out new file mode 100644 index 00000000..0d5924ec --- /dev/null +++ b/test-suite/output/SearchHead.out @@ -0,0 +1,39 @@ +le_n: forall n : nat, n <= n +le_S: forall n m : nat, n <= m -> n <= S m +le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m +le_S_n: forall n m : nat, S n <= S m -> n <= m +le_0_n: forall n : nat, 0 <= n +le_n_S: forall n m : nat, n <= m -> S n <= S m +true: bool +false: bool +andb: bool -> bool -> bool +orb: bool -> bool -> bool +implb: bool -> bool -> bool +xorb: bool -> bool -> bool +negb: bool -> bool +Nat.eqb: nat -> nat -> bool +Nat.leb: nat -> nat -> bool +Nat.ltb: nat -> nat -> bool +Nat.even: nat -> bool +Nat.odd: nat -> bool +Nat.testbit: nat -> nat -> bool +eq_S: forall x y : nat, x = y -> S x = S y +f_equal_pred: forall x y : nat, x = y -> Nat.pred x = Nat.pred y +pred_Sn: forall n : nat, n = Nat.pred (S n) +eq_add_S: forall n m : nat, S n = S m -> n = m +f_equal2_plus: + forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2 +plus_n_O: forall n : nat, n = n + 0 +plus_O_n: forall n : nat, 0 + n = n +plus_n_Sm: forall n m : nat, S (n + m) = n + S m +plus_Sn_m: forall n m : nat, S n + m = S (n + m) +f_equal2_mult: + forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 * x2 = y1 * y2 +mult_n_O: forall n : nat, 0 = n * 0 +mult_n_Sm: forall n m : nat, n * m + n = n * S m +max_l: forall n m : nat, m <= n -> Nat.max n m = n +max_r: forall n m : nat, n <= m -> Nat.max n m = m +min_l: forall n m : nat, n <= m -> Nat.min n m = n +min_r: forall n m : nat, m <= n -> Nat.min n m = m +h: newdef n +h: P n diff --git a/test-suite/output/SearchHead.v b/test-suite/output/SearchHead.v new file mode 100644 index 00000000..2ee8a0d1 --- /dev/null +++ b/test-suite/output/SearchHead.v @@ -0,0 +1,19 @@ +(* Some tests of the Search command *) + +SearchHead le. (* app nodes *) +SearchHead bool. (* no apps *) +SearchHead (@eq nat). (* complex pattern *) + +Definition newdef := fun x:nat => x = x. + +Goal forall n:nat, newdef n -> False. + intros n h. + SearchHead newdef. (* search hypothesis *) +Abort. + + +Goal forall n (P:nat -> Prop), P n -> False. + intros n P h. + SearchHead P. (* search hypothesis also for patterns *) +Abort. + diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out index 9106a4e3..1eb7eca8 100644 --- a/test-suite/output/SearchPattern.out +++ b/test-suite/output/SearchPattern.out @@ -1,30 +1,83 @@ -false: bool true: bool -xorb: bool -> bool -> bool +false: bool +andb: bool -> bool -> bool orb: bool -> bool -> bool -negb: bool -> bool implb: bool -> bool -> bool -andb: bool -> bool -> bool -S: nat -> nat +xorb: bool -> bool -> bool +negb: bool -> bool +Nat.eqb: nat -> nat -> bool +Nat.leb: nat -> nat -> bool +Nat.ltb: nat -> nat -> bool +Nat.even: nat -> bool +Nat.odd: nat -> bool +Nat.testbit: nat -> nat -> bool O: nat -pred: nat -> nat -plus: nat -> nat -> nat -mult: nat -> nat -> nat -minus: nat -> nat -> nat -min: nat -> nat -> nat -max: nat -> nat -> nat +S: nat -> nat length: forall A : Type, list A -> nat +Nat.zero: nat +Nat.one: nat +Nat.two: nat +Nat.succ: nat -> nat +Nat.pred: nat -> nat +Nat.add: nat -> nat -> nat +Nat.double: nat -> nat +Nat.mul: nat -> nat -> nat +Nat.sub: nat -> nat -> nat +Nat.max: nat -> nat -> nat +Nat.min: nat -> nat -> nat +Nat.pow: nat -> nat -> nat +Nat.div: nat -> nat -> nat +Nat.modulo: nat -> nat -> nat +Nat.gcd: nat -> nat -> nat +Nat.square: nat -> nat +Nat.sqrt_iter: nat -> nat -> nat -> nat -> nat +Nat.sqrt: nat -> nat +Nat.log2_iter: nat -> nat -> nat -> nat -> nat +Nat.log2: nat -> nat +Nat.div2: nat -> nat +Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat +Nat.land: nat -> nat -> nat +Nat.lor: nat -> nat -> nat +Nat.ldiff: nat -> nat -> nat +Nat.lxor: nat -> nat -> nat + S: nat -> nat -pred: nat -> nat -plus: nat -> nat -> nat -mult: nat -> nat -> nat -minus: nat -> nat -> nat -min: nat -> nat -> nat -max: nat -> nat -> nat +Nat.succ: nat -> nat +Nat.pred: nat -> nat +Nat.add: nat -> nat -> nat +Nat.double: nat -> nat +Nat.mul: nat -> nat -> nat +Nat.sub: nat -> nat -> nat +Nat.max: nat -> nat -> nat +Nat.min: nat -> nat -> nat +Nat.pow: nat -> nat -> nat +Nat.div: nat -> nat -> nat +Nat.modulo: nat -> nat -> nat +Nat.gcd: nat -> nat -> nat +Nat.square: nat -> nat +Nat.sqrt_iter: nat -> nat -> nat -> nat -> nat +Nat.sqrt: nat -> nat +Nat.log2_iter: nat -> nat -> nat -> nat -> nat +Nat.log2: nat -> nat +Nat.div2: nat -> nat +Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat +Nat.land: nat -> nat -> nat +Nat.lor: nat -> nat -> nat +Nat.ldiff: nat -> nat -> nat +Nat.lxor: nat -> nat -> nat mult_n_Sm: forall n m : nat, n * m + n = n * S m -le_n: forall n : nat, n <= n identity_refl: forall (A : Type) (a : A), identity a a -eq_refl: forall (A : Type) (x : A), x = x iff_refl: forall A : Prop, A <-> A +eq_refl: forall (A : Type) (x : A), x = x +Nat.divmod: nat -> nat -> nat -> nat -> nat * nat +le_n: forall n : nat, n <= n pair: forall A B : Type, A -> B -> A * B conj: forall A B : Prop, A -> B -> A /\ B +Nat.divmod: nat -> nat -> nat -> nat -> nat * nat + +h: n <> newdef n +h: n <> newdef n +h: P n +h': ~ P n +h: P n +h: P n diff --git a/test-suite/output/SearchPattern.v b/test-suite/output/SearchPattern.v index 802d8c97..bde195a5 100644 --- a/test-suite/output/SearchPattern.v +++ b/test-suite/output/SearchPattern.v @@ -17,3 +17,20 @@ SearchPattern (forall (x:?A) (y:?B), _ ?A ?B). (* No delta-reduction *) SearchPattern (Exc _). + +Definition newdef := fun x:nat => x. + +Goal forall n:nat, n <> newdef n -> False. + intros n h. + SearchPattern ( _ <> newdef _). (* search hypothesis *) + SearchPattern ( n <> newdef _). (* search hypothesis *) +Abort. + +Goal forall n (P:nat -> Prop), P n -> ~P n -> False. + intros n P h h'. + SearchPattern (P _). (* search hypothesis also for patterns *) + Search (~P n). (* search hypothesis also for patterns *) + Search (P _) -"h'". (* search hypothesis also for patterns *) + Search (P _) -not. (* search hypothesis also for patterns *) + +Abort. \ No newline at end of file diff --git a/test-suite/output/SearchRewrite.out b/test-suite/output/SearchRewrite.out index f87aea1c..5edea5df 100644 --- a/test-suite/output/SearchRewrite.out +++ b/test-suite/output/SearchRewrite.out @@ -1,2 +1,5 @@ plus_n_O: forall n : nat, n = n + 0 plus_O_n: forall n : nat, 0 + n = n +h: n = newdef n +h: n = newdef n +h: n = newdef n diff --git a/test-suite/output/SearchRewrite.v b/test-suite/output/SearchRewrite.v index 171a7363..53d043c6 100644 --- a/test-suite/output/SearchRewrite.v +++ b/test-suite/output/SearchRewrite.v @@ -2,3 +2,12 @@ SearchRewrite (_+0). (* left *) SearchRewrite (0+_). (* right *) + +Definition newdef := fun x:nat => x. + +Goal forall n:nat, n = newdef n -> False. + intros n h. + SearchRewrite (newdef _). + SearchRewrite n. (* use hypothesis for patterns *) + SearchRewrite (newdef n). (* use hypothesis for patterns *) +Abort. diff --git a/test-suite/output/TranspModtype.out b/test-suite/output/TranspModtype.out index f94ed642..67b65d4b 100644 --- a/test-suite/output/TranspModtype.out +++ b/test-suite/output/TranspModtype.out @@ -1,7 +1,15 @@ TrM.A = M.A : Set + +TrM.A is not universe polymorphic OpM.A = M.A : Set + +OpM.A is not universe polymorphic TrM.B = M.B : Set + +TrM.B is not universe polymorphic *** [ OpM.B : Set ] + +OpM.B is not universe polymorphic diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index 4f8de1dc..d69baaec 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -4,7 +4,17 @@ fun e : option L => match e with | None => None end : option L -> option L -fun n : nat => let x := A n in ?12 ?15:T n + +P is not universe polymorphic +fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H + : forall m n p : nat, S m <= S n + p -> m <= n + p +fun n : nat => let x := A n in ?y ?y0:T n : forall n : nat, T n -fun n : nat => ?20 ?23:T n +where +?y : [n : nat x := A n : T n |- ?T0 -> T n] +?y0 : [n : nat x := A n : T n |- ?T0] +fun n : nat => ?y ?y0:T n : forall n : nat, T n +where +?y : [n : nat |- ?T0 -> T n] +?y0 : [n : nat |- ?T0] diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v index 2b564f48..cd9a4a12 100644 --- a/test-suite/output/inference.v +++ b/test-suite/output/inference.v @@ -13,6 +13,10 @@ Definition P (e:option L) := Print P. +(* Check that plus is folded even if reduction is involved *) +Check (fun m n p (H : S m <= (S n) + p) => le_S_n _ _ H). + + (* Check that the heuristic to solve constraints is not artificially dependent on the presence of a let-in, and in particular that the second [_] below is not inferred to be n, as if obtained by diff --git a/test-suite/output/names.out b/test-suite/output/names.out new file mode 100644 index 00000000..2892dfd5 --- /dev/null +++ b/test-suite/output/names.out @@ -0,0 +1,6 @@ +The command has indeed failed with message: +=> Error: +In environment +y : nat +The term "a y" has type "{y0 : nat | y = y0}" +while it is expected to have type "{x : nat | x = y}". diff --git a/test-suite/output/names.v b/test-suite/output/names.v new file mode 100644 index 00000000..b3b5071a --- /dev/null +++ b/test-suite/output/names.v @@ -0,0 +1,5 @@ +(* Test no clash names occur *) +(* see bug #2723 *) + +Parameter a : forall x, {y:nat|x=y}. +Fail Definition b y : {x:nat|x=y} := a y. diff --git a/test-suite/output/reduction.v b/test-suite/output/reduction.v index c4592369..ab626282 100644 --- a/test-suite/output/reduction.v +++ b/test-suite/output/reduction.v @@ -1,6 +1,6 @@ (* Test the behaviour of hnf and simpl introduced in revision *) -Variable n:nat. +Parameter n:nat. Definition a:=0. Eval simpl in (fix plus (n m : nat) {struct n} : nat := diff --git a/test-suite/output/set.out b/test-suite/output/set.out index 333fbb86..4dfd2bc2 100644 --- a/test-suite/output/set.out +++ b/test-suite/output/set.out @@ -6,16 +6,13 @@ x = x 1 subgoal - y1 := 0 : nat - y2 := 0 : nat + y1, y2 := 0 : nat x := y2 + 0 : nat ============================ x = x 1 subgoal - y1 := 0 : nat - y2 := 0 : nat - y3 := 0 : nat + y1, y2, y3 := 0 : nat x := y2 + y3 : nat ============================ x = x diff --git a/test-suite/output/simpl.v b/test-suite/output/simpl.v index 5f1926f1..89638eed 100644 --- a/test-suite/output/simpl.v +++ b/test-suite/output/simpl.v @@ -4,10 +4,10 @@ Goal forall x, 0+x = 1+x. intro x. simpl (_ + x). Show. -Undo. +Undo 2. simpl (_ + x) at 2. Show. -Undo. +Undo 2. simpl (0 + _). Show. -Undo. +Undo 2. diff --git a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v new file mode 100755 index 00000000..0d75d52a --- /dev/null +++ b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v @@ -0,0 +1,3041 @@ +(* This program is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Lesser General Public License *) +(* as published by the Free Software Foundation; either version 2.1 *) +(* 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 Lesser General Public *) +(* License along with this program; if not, write to the Free *) +(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *) +(* 02110-1301 USA *) + + +(** This file includes random facts about Integers (and natural numbers) which are not found in the standard library. Some of the lemma here are not used in the QArith developement but are rather useful. +*) + +Require Export ZArith. +Require Export ZArithRing. + +Tactic Notation "ElimCompare" constr(c) constr(d) := elim_compare c d. + +Ltac Flip := + apply Zgt_lt || apply Zlt_gt || apply Zle_ge || apply Zge_le; assumption. + +Ltac Falsum := + try intro; apply False_ind; + repeat + match goal with + | id1:(~ ?X1) |- ?X2 => + (apply id1; assumption || reflexivity) || clear id1 + end. + + +Ltac Step_l a := + match goal with + | |- (?X1 < ?X2)%Z => replace X1 with a; [ idtac | try ring ] + end. + +Ltac Step_r a := + match goal with + | |- (?X1 < ?X2)%Z => replace X2 with a; [ idtac | try ring ] + end. + +Ltac CaseEq formula := + generalize (refl_equal formula); pattern formula at -1 in |- *; + case formula. + + +Lemma pair_1 : forall (A B : Set) (H : A * B), H = pair (fst H) (snd H). +Proof. + intros. + case H. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma pair_2 : + forall (A B : Set) (H1 H2 : A * B), + fst H1 = fst H2 -> snd H1 = snd H2 -> H1 = H2. +Proof. + intros A B H1 H2. + case H1. + case H2. + simpl in |- *. + intros. + rewrite H. + rewrite H0. + reflexivity. +Qed. + + +Section projection. + Variable A : Set. + Variable P : A -> Prop. + + Definition projP1 (H : sig P) := let (x, h) := H in x. + Definition projP2 (H : sig P) := + let (x, h) as H return (P (projP1 H)) := H in h. +End projection. + + +(*###########################################################################*) +(* Declaring some realtions on natural numbers for stepl and stepr tactics. *) +(*###########################################################################*) + +Lemma le_stepl: forall x y z, le x y -> x=z -> le z y. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma le_stepr: forall x y z, le x y -> y=z -> le x z. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma lt_stepl: forall x y z, lt x y -> x=z -> lt z y. +Proof. + intros x y z H_lt H_eq; subst z; trivial. +Qed. + +Lemma lt_stepr: forall x y z, lt x y -> y=z -> lt x z. +Proof. + intros x y z H_lt H_eq; subst z; trivial. +Qed. + +Lemma neq_stepl:forall (x y z:nat), x<>y -> x=z -> z<>y. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + +Lemma neq_stepr:forall (x y z:nat), x<>y -> y=z -> x<>z. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + + +Declare Left Step le_stepl. +Declare Right Step le_stepr. +Declare Left Step lt_stepl. +Declare Right Step lt_stepr. +Declare Left Step neq_stepl. +Declare Right Step neq_stepr. + +(*###########################################################################*) +(** Some random facts about natural numbers, positive numbers and integers *) +(*###########################################################################*) + + +Lemma not_O_S : forall n : nat, n <> 0 -> {p : nat | n = S p}. +Proof. + intros [| np] Hn; [ exists 0; apply False_ind; apply Hn | exists np ]; + reflexivity. +Qed. + + +Lemma lt_minus_neq : forall m n : nat, m < n -> n - m <> 0. +Proof. + intros. + omega. +Qed. + +Lemma lt_minus_eq_0 : forall m n : nat, m < n -> m - n = 0. +Proof. + intros. + omega. +Qed. + +Lemma le_plus_Sn_1_SSn : forall n : nat, S n + 1 <= S (S n). +Proof. + intros. + omega. +Qed. + +Lemma le_plus_O_l : forall p q : nat, p + q <= 0 -> p = 0. +Proof. + intros; omega. +Qed. + +Lemma le_plus_O_r : forall p q : nat, p + q <= 0 -> q = 0. +Proof. + intros; omega. +Qed. + +Lemma minus_pred : forall m n : nat, 0 < n -> pred m - pred n = m - n. +Proof. + intros. + omega. +Qed. + + +(*###########################################################################*) +(* Declaring some realtions on integers for stepl and stepr tactics. *) +(*###########################################################################*) + +Lemma Zle_stepl: forall x y z, (x<=y)%Z -> x=z -> (z<=y)%Z. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma Zle_stepr: forall x y z, (x<=y)%Z -> y=z -> (x<=z)%Z. +Proof. + intros x y z H_le H_eq; subst z; trivial. +Qed. + +Lemma Zlt_stepl: forall x y z, (x x=z -> (z y=z -> (xy)%Z -> x=z -> (z<>y)%Z. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + +Lemma Zneq_stepr:forall (x y z:Z), (x<>y)%Z -> y=z -> (x<>z)%Z. +Proof. + intros x y z H_lt H_eq; subst; assumption. +Qed. + +Declare Left Step Zle_stepl. +Declare Right Step Zle_stepr. +Declare Left Step Zlt_stepl. +Declare Right Step Zlt_stepr. +Declare Left Step Zneq_stepl. +Declare Right Step Zneq_stepr. + + +(*###########################################################################*) +(** Informative case analysis *) +(*###########################################################################*) + +Lemma Zlt_cotrans : + forall x y : Z, (x < y)%Z -> forall z : Z, {(x < z)%Z} + {(z < y)%Z}. +Proof. + intros. + case (Z_lt_ge_dec x z). + intro. + left. + assumption. + intro. + right. + apply Zle_lt_trans with (m := x). + apply Zge_le. + assumption. + assumption. +Qed. + +Lemma Zlt_cotrans_pos : + forall x y : Z, (0 < x + y)%Z -> {(0 < x)%Z} + {(0 < y)%Z}. +Proof. + intros. + case (Zlt_cotrans 0 (x + y) H x). + intro. + left. + assumption. + intro. + right. + apply Zplus_lt_reg_l with (p := x). + rewrite Zplus_0_r. + assumption. +Qed. + + +Lemma Zlt_cotrans_neg : + forall x y : Z, (x + y < 0)%Z -> {(x < 0)%Z} + {(y < 0)%Z}. +Proof. + intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy; + [ right; apply Zplus_lt_reg_l with (p := x); rewrite Zplus_0_r | left ]; + assumption. +Qed. + + + +Lemma not_Zeq_inf : forall x y : Z, x <> y -> {(x < y)%Z} + {(y < x)%Z}. +Proof. + intros. + case Z_lt_ge_dec with x y. + intro. + left. + assumption. + intro H0. + generalize (Zge_le _ _ H0). + intro. + case (Z_le_lt_eq_dec _ _ H1). + intro. + right. + assumption. + intro. + apply False_rec. + apply H. + symmetry in |- *. + assumption. +Qed. + +Lemma Z_dec : forall x y : Z, {(x < y)%Z} + {(x > y)%Z} + {x = y}. +Proof. + intros. + case (Z_lt_ge_dec x y). + intro H. + left. + left. + assumption. + intro H. + generalize (Zge_le _ _ H). + intro H0. + case (Z_le_lt_eq_dec y x H0). + intro H1. + left. + right. + apply Zlt_gt. + assumption. + intro. + right. + symmetry in |- *. + assumption. +Qed. + + +Lemma Z_dec' : forall x y : Z, {(x < y)%Z} + {(y < x)%Z} + {x = y}. +Proof. + intros x y. + case (Z_eq_dec x y); intro H; + [ right; assumption | left; apply (not_Zeq_inf _ _ H) ]. +Qed. + +Lemma Z_lt_le_dec : forall x y : Z, {(x < y)%Z} + {(y <= x)%Z}. +Proof. + intros. + case (Z_lt_ge_dec x y). + intro. + left. + assumption. + intro. + right. + apply Zge_le. + assumption. +Qed. + +Lemma Z_le_lt_dec : forall x y : Z, {(x <= y)%Z} + {(y < x)%Z}. +Proof. + intros; case (Z_lt_le_dec y x); [ right | left ]; assumption. +Qed. + +Lemma Z_lt_lt_S_eq_dec : + forall x y : Z, (x < y)%Z -> {(x + 1 < y)%Z} + {(x + 1)%Z = y}. +Proof. + intros. + generalize (Zlt_le_succ _ _ H). + unfold Zsucc in |- *. + apply Z_le_lt_eq_dec. +Qed. + +Lemma quadro_leq_inf : + forall a b c d : Z, + {(c <= a)%Z /\ (d <= b)%Z} + {~ ((c <= a)%Z /\ (d <= b)%Z)}. +Proof. + intros. + case (Z_lt_le_dec a c). + intro z. + right. + intro. + elim H. + intros. + generalize z. + apply Zle_not_lt. + assumption. + intro. + case (Z_lt_le_dec b d). + intro z0. + right. + intro. + elim H. + intros. + generalize z0. + apply Zle_not_lt. + assumption. + intro. + left. + split. + assumption. + assumption. +Qed. + +(*###########################################################################*) +(** General auxiliary lemmata *) +(*###########################################################################*) + +Lemma Zminus_eq : forall x y : Z, (x - y)%Z = 0%Z -> x = y. +Proof. + intros. + apply Zplus_reg_l with (- y)%Z. + rewrite Zplus_opp_l. + unfold Zminus in H. + rewrite Zplus_comm. + assumption. +Qed. + +Lemma Zlt_minus : forall a b : Z, (b < a)%Z -> (0 < a - b)%Z. +Proof. + intros a b. + intros. + apply Zplus_lt_reg_l with b. + unfold Zminus in |- *. + rewrite (Zplus_comm a). + rewrite (Zplus_assoc b (- b)). + rewrite Zplus_opp_r. + simpl in |- *. + rewrite <- Zplus_0_r_reverse. + assumption. +Qed. + + +Lemma Zle_minus : forall a b : Z, (b <= a)%Z -> (0 <= a - b)%Z. +Proof. + intros a b. + intros. + apply Zplus_le_reg_l with b. + unfold Zminus in |- *. + rewrite (Zplus_comm a). + rewrite (Zplus_assoc b (- b)). + rewrite Zplus_opp_r. + simpl in |- *. + rewrite <- Zplus_0_r_reverse. + assumption. +Qed. + +Lemma Zlt_plus_plus : + forall m n p q : Z, (m < n)%Z -> (p < q)%Z -> (m + p < n + q)%Z. +Proof. + intros. + apply Zlt_trans with (m := (n + p)%Z). + rewrite Zplus_comm. + rewrite Zplus_comm with (n := n). + apply Zplus_lt_compat_l. + assumption. + apply Zplus_lt_compat_l. + assumption. +Qed. + +Lemma Zgt_plus_plus : + forall m n p q : Z, (m > n)%Z -> (p > q)%Z -> (m + p > n + q)%Z. + intros. + apply Zgt_trans with (m := (n + p)%Z). + rewrite Zplus_comm. + rewrite Zplus_comm with (n := n). + apply Zplus_gt_compat_l. + assumption. + apply Zplus_gt_compat_l. + assumption. +Qed. + +Lemma Zle_lt_plus_plus : + forall m n p q : Z, (m <= n)%Z -> (p < q)%Z -> (m + p < n + q)%Z. +Proof. + intros. + case (Zle_lt_or_eq m n). + assumption. + intro. + apply Zlt_plus_plus. + assumption. + assumption. + intro. + rewrite H1. + apply Zplus_lt_compat_l. + assumption. +Qed. + +Lemma Zge_gt_plus_plus : + forall m n p q : Z, (m >= n)%Z -> (p > q)%Z -> (m + p > n + q)%Z. +Proof. + intros. + case (Zle_lt_or_eq n m). + apply Zge_le. + assumption. + intro. + apply Zgt_plus_plus. + apply Zlt_gt. + assumption. + assumption. + intro. + rewrite H1. + apply Zplus_gt_compat_l. + assumption. +Qed. + +Lemma Zgt_ge_plus_plus : + forall m n p q : Z, (m > n)%Z -> (p >= q)%Z -> (m + p > n + q)%Z. +Proof. + intros. + rewrite Zplus_comm. + replace (n + q)%Z with (q + n)%Z. + apply Zge_gt_plus_plus. + assumption. + assumption. + apply Zplus_comm. +Qed. + +Lemma Zlt_resp_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x + y)%Z. +Proof. + intros. + rewrite <- Zplus_0_r with 0%Z. + apply Zlt_plus_plus; assumption. +Qed. + + +Lemma Zle_resp_neg : + forall x y : Z, (x <= 0)%Z -> (y <= 0)%Z -> (x + y <= 0)%Z. +Proof. + intros. + rewrite <- Zplus_0_r with 0%Z. + apply Zplus_le_compat; assumption. +Qed. + + +Lemma Zlt_pos_opp : forall x : Z, (0 < x)%Z -> (- x < 0)%Z. +Proof. + intros. + apply Zplus_lt_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + +Lemma Zlt_neg_opp : forall x : Z, (x < 0)%Z -> (0 < - x)%Z. +Proof. + intros. + apply Zplus_lt_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + + +Lemma Zle_neg_opp : forall x : Z, (x <= 0)%Z -> (0 <= - x)%Z. +Proof. + intros. + apply Zplus_le_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + +Lemma Zle_pos_opp : forall x : Z, (0 <= x)%Z -> (- x <= 0)%Z. +Proof. + intros. + apply Zplus_le_reg_l with x. + rewrite Zplus_opp_r. + rewrite Zplus_0_r. + assumption. +Qed. + + +Lemma Zge_opp : forall x y : Z, (x <= y)%Z -> (- x >= - y)%Z. +Proof. + intros. + apply Zle_ge. + apply Zplus_le_reg_l with (p := (x + y)%Z). + ring_simplify (x + y + - y)%Z (x + y + - x)%Z. + assumption. +Qed. + + + +(* Omega can't solve this *) +Lemma Zmult_pos_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x * y)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + +Lemma Zmult_neg_neg : forall x y : Z, (x < 0)%Z -> (y < 0)%Z -> (0 < x * y)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + +Lemma Zmult_neg_pos : forall x y : Z, (x < 0)%Z -> (0 < y)%Z -> (x * y < 0)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + +Lemma Zmult_pos_neg : forall x y : Z, (0 < x)%Z -> (y < 0)%Z -> (x * y < 0)%Z. +Proof. + intros [| px| px] [| py| py] Hx Hy; trivial || constructor. +Qed. + + + +Hint Resolve Zmult_pos_pos Zmult_neg_neg Zmult_neg_pos Zmult_pos_neg: zarith. + + +Lemma Zle_reg_mult_l : + forall x y a : Z, (0 < a)%Z -> (x <= y)%Z -> (a * x <= a * y)%Z. +Proof. + intros. + apply Zplus_le_reg_l with (p := (- a * x)%Z). + ring_simplify (- a * x + a * x)%Z. + replace (- a * x + a * y)%Z with ((y - x) * a)%Z. + apply Zmult_gt_0_le_0_compat. + apply Zlt_gt. + assumption. + unfold Zminus in |- *. + apply Zle_left. + assumption. + ring. +Qed. + +Lemma Zsimpl_plus_l_dep : + forall x y m n : Z, (x + m)%Z = (y + n)%Z -> x = y -> m = n. +Proof. + intros. + apply Zplus_reg_l with x. + rewrite <- H0 in H. + assumption. +Qed. + + +Lemma Zsimpl_plus_r_dep : + forall x y m n : Z, (m + x)%Z = (n + y)%Z -> x = y -> m = n. +Proof. + intros. + apply Zplus_reg_l with x. + rewrite Zplus_comm. + rewrite Zplus_comm with x n. + rewrite <- H0 in H. + assumption. +Qed. + +Lemma Zmult_simpl : + forall n m p q : Z, n = m -> p = q -> (n * p)%Z = (m * q)%Z. +Proof. + intros. + rewrite H. + rewrite H0. + reflexivity. +Qed. + +Lemma Zsimpl_mult_l : + forall n m p : Z, n <> 0%Z -> (n * m)%Z = (n * p)%Z -> m = p. +Proof. + intros. + apply Zplus_reg_l with (n := (- p)%Z). + replace (- p + p)%Z with 0%Z. + apply Zmult_integral_l with (n := n). + assumption. + replace ((- p + m) * n)%Z with (n * m + - (n * p))%Z. + apply Zegal_left. + assumption. + ring. + ring. +Qed. + +Lemma Zlt_reg_mult_l : + forall x y z : Z, (x > 0)%Z -> (y < z)%Z -> (x * y < x * z)%Z. (*QA*) +Proof. + intros. + case (Zcompare_Gt_spec x 0). + unfold Zgt in H. + assumption. + intros. + cut (x = Zpos x0). + intro. + rewrite H2. + unfold Zlt in H0. + unfold Zlt in |- *. + cut ((Zpos x0 * y ?= Zpos x0 * z)%Z = (y ?= z)%Z). + intro. + exact (trans_eq H3 H0). + apply Zcompare_mult_compat. + cut (x = (x + - (0))%Z). + intro. + exact (trans_eq H2 H1). + simpl in |- *. + apply (sym_eq (A:=Z)). + exact (Zplus_0_r x). +Qed. + + +Lemma Zlt_opp : forall x y : Z, (x < y)%Z -> (- x > - y)%Z. (*QA*) +Proof. + intros. + red in |- *. + apply sym_eq. + cut (Datatypes.Gt = (y ?= x)%Z). + intro. + cut ((y ?= x)%Z = (- x ?= - y)%Z). + intro. + exact (trans_eq H0 H1). + exact (Zcompare_opp y x). + apply sym_eq. + exact (Zlt_gt x y H). +Qed. + + +Lemma Zlt_conv_mult_l : + forall x y z : Z, (x < 0)%Z -> (y < z)%Z -> (x * y > x * z)%Z. (*QA*) +Proof. + intros. + cut (- x > 0)%Z. + intro. + cut (- x * y < - x * z)%Z. + intro. + cut (- (- x * y) > - (- x * z))%Z. + intro. + cut (- - (x * y) > - - (x * z))%Z. + intro. + cut ((- - (x * y))%Z = (x * y)%Z). + intro. + rewrite H5 in H4. + cut ((- - (x * z))%Z = (x * z)%Z). + intro. + rewrite H6 in H4. + assumption. + exact (Zopp_involutive (x * z)). + exact (Zopp_involutive (x * y)). + cut ((- (- x * y))%Z = (- - (x * y))%Z). + intro. + rewrite H4 in H3. + cut ((- (- x * z))%Z = (- - (x * z))%Z). + intro. + rewrite H5 in H3. + assumption. + cut ((- x * z)%Z = (- (x * z))%Z). + intro. + exact (f_equal Zopp H5). + exact (Zopp_mult_distr_l_reverse x z). + cut ((- x * y)%Z = (- (x * y))%Z). + intro. + exact (f_equal Zopp H4). + exact (Zopp_mult_distr_l_reverse x y). + exact (Zlt_opp (- x * y) (- x * z) H2). + exact (Zlt_reg_mult_l (- x) y z H1 H0). + exact (Zlt_opp x 0 H). +Qed. + +Lemma Zgt_not_eq : forall x y : Z, (x > y)%Z -> x <> y. (*QA*) +Proof. + intros. + cut (y < x)%Z. + intro. + cut (y <> x). + intro. + red in |- *. + intros. + cut (y = x). + intros. + apply H1. + assumption. + exact (sym_eq H2). + exact (Zorder.Zlt_not_eq y x H0). + exact (Zgt_lt x y H). +Qed. + +Lemma Zmult_resp_nonzero : + forall x y : Z, x <> 0%Z -> y <> 0%Z -> (x * y)%Z <> 0%Z. +Proof. + intros x y Hx Hy Hxy. + apply Hx. + apply Zmult_integral_l with y; assumption. +Qed. + + +Lemma Zopp_app : forall y : Z, y <> 0%Z -> (- y)%Z <> 0%Z. +Proof. + intros. + intro. + apply H. + apply Zplus_reg_l with (- y)%Z. + rewrite Zplus_opp_l. + rewrite H0. + simpl in |- *. + reflexivity. +Qed. + + +Lemma Zle_neq_Zlt : forall a b : Z, (a <= b)%Z -> b <> a -> (a < b)%Z. +Proof. + intros a b H H0. + case (Z_le_lt_eq_dec _ _ H); trivial. + intro; apply False_ind; apply H0; symmetry in |- *; assumption. +Qed. + +Lemma not_Zle_lt : forall x y : Z, ~ (y <= x)%Z -> (x < y)%Z. +Proof. + intros; apply Zgt_lt; apply Znot_le_gt; assumption. +Qed. + +Lemma not_Zlt : forall x y : Z, ~ (y < x)%Z -> (x <= y)%Z. +Proof. + intros x y H1 H2; apply H1; apply Zgt_lt; assumption. +Qed. + + +Lemma Zmult_absorb : + forall x y z : Z, x <> 0%Z -> (x * y)%Z = (x * z)%Z -> y = z. (*QA*) +Proof. + intros. + case (dec_eq y z). + intro. + assumption. + intro. + case (not_Zeq y z). + assumption. + intro. + case (not_Zeq x 0). + assumption. + intro. + apply False_ind. + cut (x * y > x * z)%Z. + intro. + cut ((x * y)%Z <> (x * z)%Z). + intro. + apply H5. + assumption. + exact (Zgt_not_eq (x * y) (x * z) H4). + exact (Zlt_conv_mult_l x y z H3 H2). + intro. + apply False_ind. + cut (x * y < x * z)%Z. + intro. + cut ((x * y)%Z <> (x * z)%Z). + intro. + apply H5. + assumption. + exact (Zorder.Zlt_not_eq (x * y) (x * z) H4). + cut (x > 0)%Z. + intro. + exact (Zlt_reg_mult_l x y z H4 H2). + exact (Zlt_gt 0 x H3). + intro. + apply False_ind. + cut (x * z < x * y)%Z. + intro. + cut ((x * z)%Z <> (x * y)%Z). + intro. + apply H4. + apply (sym_eq (A:=Z)). + assumption. + exact (Zorder.Zlt_not_eq (x * z) (x * y) H3). + apply False_ind. + case (not_Zeq x 0). + assumption. + intro. + cut (x * z > x * y)%Z. + intro. + cut ((x * z)%Z <> (x * y)%Z). + intro. + apply H5. + apply (sym_eq (A:=Z)). + assumption. + exact (Zgt_not_eq (x * z) (x * y) H4). + exact (Zlt_conv_mult_l x z y H3 H2). + intro. + cut (x * z < x * y)%Z. + intro. + cut ((x * z)%Z <> (x * y)%Z). + intro. + apply H5. + apply (sym_eq (A:=Z)). + assumption. + exact (Zorder.Zlt_not_eq (x * z) (x * y) H4). + cut (x > 0)%Z. + intro. + exact (Zlt_reg_mult_l x z y H4 H2). + exact (Zlt_gt 0 x H3). +Qed. + +Lemma Zlt_mult_mult : + forall a b c d : Z, + (0 < a)%Z -> (0 < d)%Z -> (a < b)%Z -> (c < d)%Z -> (a * c < b * d)%Z. +Proof. + intros. + apply Zlt_trans with (a * d)%Z. + apply Zlt_reg_mult_l. + Flip. + assumption. + rewrite Zmult_comm. + rewrite Zmult_comm with b d. + apply Zlt_reg_mult_l. + Flip. + assumption. +Qed. + +Lemma Zgt_mult_conv_absorb_l : + forall a x y : Z, (a < 0)%Z -> (a * x > a * y)%Z -> (x < y)%Z. (*QC*) +Proof. + intros. + case (dec_eq x y). + intro. + apply False_ind. + rewrite H1 in H0. + cut ((a * y)%Z = (a * y)%Z). + change ((a * y)%Z <> (a * y)%Z) in |- *. + apply Zgt_not_eq. + assumption. + trivial. + + intro. + case (not_Zeq x y H1). + trivial. + + intro. + apply False_ind. + cut (a * y > a * x)%Z. + apply Zgt_asym with (m := (a * y)%Z) (n := (a * x)%Z). + assumption. + apply Zlt_conv_mult_l. + assumption. + assumption. +Qed. + +Lemma Zgt_mult_reg_absorb_l : + forall a x y : Z, (a > 0)%Z -> (a * x > a * y)%Z -> (x > y)%Z. (*QC*) +Proof. + intros. + cut (- - a > - - (0))%Z. + intro. + cut (- a < - (0))%Z. + simpl in |- *. + intro. + replace x with (- - x)%Z. + replace y with (- - y)%Z. + apply Zlt_opp. + apply Zgt_mult_conv_absorb_l with (a := (- a)%Z) (x := (- x)%Z). + assumption. + rewrite Zmult_opp_opp. + rewrite Zmult_opp_opp. + assumption. + apply Zopp_involutive. + apply Zopp_involutive. + apply Zgt_lt. + apply Zlt_opp. + apply Zgt_lt. + assumption. + simpl in |- *. + rewrite Zopp_involutive. + assumption. +Qed. + +Lemma Zopp_Zlt : forall x y : Z, (y < x)%Z -> (- x < - y)%Z. +Proof. + intros x y Hyx. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + replace (-1 * - y)%Z with y. + replace (-1 * - x)%Z with x. + Flip. + ring. + ring. +Qed. + + +Lemma Zmin_cancel_Zlt : forall x y : Z, (- x < - y)%Z -> (y < x)%Z. +Proof. + intros. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + replace (-1 * y)%Z with (- y)%Z. + replace (-1 * x)%Z with (- x)%Z. + apply Zlt_gt. + assumption. + ring. + ring. +Qed. + + +Lemma Zmult_cancel_Zle : + forall a x y : Z, (a < 0)%Z -> (a * x <= a * y)%Z -> (y <= x)%Z. +Proof. + intros. + case (Z_le_gt_dec y x). + trivial. + intro. + apply False_ind. + apply (Zlt_irrefl (a * x)). + apply Zle_lt_trans with (m := (a * y)%Z). + assumption. + apply Zgt_lt. + apply Zlt_conv_mult_l. + assumption. + apply Zgt_lt. + assumption. +Qed. + +Lemma Zlt_mult_cancel_l : + forall x y z : Z, (0 < x)%Z -> (x * y < x * z)%Z -> (y < z)%Z. +Proof. + intros. + apply Zgt_lt. + apply Zgt_mult_reg_absorb_l with x. + apply Zlt_gt. + assumption. + apply Zlt_gt. + assumption. +Qed. + + +Lemma Zmin_cancel_Zle : forall x y : Z, (- x <= - y)%Z -> (y <= x)%Z. +Proof. + intros. + apply Zmult_cancel_Zle with (a := (-1)%Z). + constructor. + replace (-1 * y)%Z with (- y)%Z. + replace (-1 * x)%Z with (- x)%Z. + assumption. + ring. + ring. +Qed. + + + +Lemma Zmult_resp_Zle : + forall a x y : Z, (0 < a)%Z -> (a * y <= a * x)%Z -> (y <= x)%Z. +Proof. + intros. + case (Z_le_gt_dec y x). + trivial. + intro. + apply False_ind. + apply (Zlt_irrefl (a * y)). + apply Zle_lt_trans with (m := (a * x)%Z). + assumption. + apply Zlt_reg_mult_l. + apply Zlt_gt. + assumption. + apply Zgt_lt. + assumption. +Qed. + +Lemma Zopp_Zle : forall x y : Z, (y <= x)%Z -> (- x <= - y)%Z. +Proof. + intros. + apply Zmult_cancel_Zle with (a := (-1)%Z). + constructor. + replace (-1 * - y)%Z with y. + replace (-1 * - x)%Z with x. + assumption. + clear y H; ring. + clear x H; ring. +Qed. + + +Lemma Zle_lt_eq_S : forall x y : Z, (x <= y)%Z -> (y < x + 1)%Z -> y = x. +Proof. + intros. + case (Z_le_lt_eq_dec x y H). + intro H1. + apply False_ind. + generalize (Zlt_le_succ x y H1). + intro. + apply (Zlt_not_le y (x + 1) H0). + replace (x + 1)%Z with (Zsucc x). + assumption. + reflexivity. + intro H1. + symmetry in |- *. + assumption. +Qed. + +Lemma Zlt_le_eq_S : + forall x y : Z, (x < y)%Z -> (y <= x + 1)%Z -> y = (x + 1)%Z. +Proof. + intros. + case (Z_le_lt_eq_dec y (x + 1) H0). + intro H1. + apply False_ind. + generalize (Zlt_le_succ x y H). + intro. + apply (Zlt_not_le y (x + 1) H1). + replace (x + 1)%Z with (Zsucc x). + assumption. + reflexivity. + trivial. +Qed. + + +Lemma double_not_equal_zero : + forall c d : Z, ~ (c = 0%Z /\ d = 0%Z) -> c <> d \/ c <> 0%Z. +Proof. + intros. + case (Z_zerop c). + intro. + rewrite e. + left. + apply sym_not_eq. + intro. + apply H; repeat split; assumption. + intro; right; assumption. +Qed. + +Lemma triple_not_equal_zero : + forall a b c : Z, + ~ (a = 0%Z /\ b = 0%Z /\ c = 0%Z) -> a <> 0%Z \/ b <> 0%Z \/ c <> 0%Z. +Proof. + intros a b c H; case (Z_zerop a); intro Ha; + [ case (Z_zerop b); intro Hb; + [ case (Z_zerop c); intro Hc; + [ apply False_ind; apply H; repeat split | right; right ] + | right; left ] + | left ]; assumption. +Qed. + +Lemma mediant_1 : + forall m n m' n' : Z, (m' * n < m * n')%Z -> ((m + m') * n < m * (n + n'))%Z. +Proof. + intros. + rewrite Zmult_plus_distr_r. + rewrite Zmult_plus_distr_l. + apply Zplus_lt_compat_l. + assumption. +Qed. + +Lemma mediant_2 : + forall m n m' n' : Z, + (m' * n < m * n')%Z -> (m' * (n + n') < (m + m') * n')%Z. +Proof. + intros. + rewrite Zmult_plus_distr_l. + rewrite Zmult_plus_distr_r. + apply Zplus_lt_compat_r. + assumption. +Qed. + + +Lemma mediant_3 : + forall a b m n m' n' : Z, + (0 <= a * m + b * n)%Z -> + (0 <= a * m' + b * n')%Z -> (0 <= a * (m + m') + b * (n + n'))%Z. +Proof. + intros. + replace (a * (m + m') + b * (n + n'))%Z with + (a * m + b * n + (a * m' + b * n'))%Z. + apply Zplus_le_0_compat. + assumption. + assumption. + ring. +Qed. + +Lemma fraction_lt_trans : + forall a b c d e f : Z, + (0 < b)%Z -> + (0 < d)%Z -> + (0 < f)%Z -> (a * d < c * b)%Z -> (c * f < e * d)%Z -> (a * f < e * b)%Z. +Proof. + intros. + apply Zgt_lt. + apply Zgt_mult_reg_absorb_l with d. + Flip. + apply Zgt_trans with (c * b * f)%Z. + replace (d * (e * b))%Z with (b * (e * d))%Z. + replace (c * b * f)%Z with (b * (c * f))%Z. + apply Zlt_gt. + apply Zlt_reg_mult_l. + Flip. + assumption. + ring. + ring. + replace (c * b * f)%Z with (f * (c * b))%Z. + replace (d * (a * f))%Z with (f * (a * d))%Z. + apply Zlt_gt. + apply Zlt_reg_mult_l. + Flip. + assumption. + ring. + ring. +Qed. + + +Lemma square_pos : forall a : Z, a <> 0%Z -> (0 < a * a)%Z. +Proof. + intros [| p| p]; intros; [ Falsum | constructor | constructor ]. +Qed. + +Hint Resolve square_pos: zarith. + +(*###########################################################################*) +(** Properties of positive numbers, mapping between Z and nat *) +(*###########################################################################*) + + +Definition Z2positive (z : Z) := + match z with + | Zpos p => p + | Zneg p => p + | Z0 => 1%positive + end. + + +Lemma ZL9 : forall p : positive, Z_of_nat (nat_of_P p) = Zpos p. (*QF*) +Proof. + intro. + cut (exists h : nat, nat_of_P p = S h). + intro. + case H. + intros. + unfold Z_of_nat in |- *. + rewrite H0. + + apply f_equal with (A := positive) (B := Z) (f := Zpos). + cut (P_of_succ_nat (nat_of_P p) = P_of_succ_nat (S x)). + intro. + rewrite P_of_succ_nat_o_nat_of_P_eq_succ in H1. + cut (Ppred (Psucc p) = Ppred (P_of_succ_nat (S x))). + intro. + rewrite Ppred_succ in H2. + simpl in H2. + rewrite Ppred_succ in H2. + apply sym_eq. + assumption. + apply f_equal with (A := positive) (B := positive) (f := Ppred). + assumption. + apply f_equal with (f := P_of_succ_nat). + assumption. + apply ZL4. +Qed. + +Coercion Z_of_nat : nat >-> Z. + +Lemma ZERO_lt_POS : forall p : positive, (0 < Zpos p)%Z. +Proof. + intros. + constructor. +Qed. + + +Lemma POS_neq_ZERO : forall p : positive, Zpos p <> 0%Z. +Proof. + intros. + apply sym_not_eq. + apply Zorder.Zlt_not_eq. + apply ZERO_lt_POS. +Qed. + +Lemma NEG_neq_ZERO : forall p : positive, Zneg p <> 0%Z. +Proof. + intros. + apply Zorder.Zlt_not_eq. + unfold Zlt in |- *. + constructor. +Qed. + + +Lemma POS_resp_eq : forall p0 p1 : positive, Zpos p0 = Zpos p1 -> p0 = p1. +Proof. + intros. + injection H. + trivial. +Qed. + +Lemma nat_nat_pos : forall m n : nat, ((m + 1) * (n + 1) > 0)%Z. (*QF*) +Proof. + intros. + apply Zlt_gt. + cut (Z_of_nat m + 1 > 0)%Z. + intro. + cut (0 < Z_of_nat n + 1)%Z. + intro. + cut ((Z_of_nat m + 1) * 0 < (Z_of_nat m + 1) * (Z_of_nat n + 1))%Z. + rewrite Zmult_0_r. + intro. + assumption. + + apply Zlt_reg_mult_l. + assumption. + assumption. + change (0 < Zsucc (Z_of_nat n))%Z in |- *. + apply Zle_lt_succ. + change (Z_of_nat 0 <= Z_of_nat n)%Z in |- *. + apply Znat.inj_le. + apply le_O_n. + apply Zlt_gt. + change (0 < Zsucc (Z_of_nat m))%Z in |- *. + apply Zle_lt_succ. + change (Z_of_nat 0 <= Z_of_nat m)%Z in |- *. + apply Znat.inj_le. + apply le_O_n. +Qed. + + +Theorem S_predn : forall m : nat, m <> 0 -> S (pred m) = m. (*QF*) +Proof. + intros. + case (O_or_S m). + intro. + case s. + intros. + rewrite <- e. + rewrite <- pred_Sn with (n := x). + trivial. + intro. + apply False_ind. + apply H. + apply sym_eq. + assumption. +Qed. + +Lemma absolu_1 : forall x : Z, Zabs_nat x = 0 -> x = 0%Z. (*QF*) +Proof. + intros. + case (dec_eq x 0). + intro. + assumption. + intro. + apply False_ind. + cut ((x < 0)%Z \/ (x > 0)%Z). + intro. + ElimCompare x 0%Z. + intro. + cut (x = 0%Z). + assumption. + cut ((x ?= 0)%Z = Datatypes.Eq -> x = 0%Z). + intro. + apply H3. + assumption. + apply proj1 with (B := x = 0%Z -> (x ?= 0)%Z = Datatypes.Eq). + change ((x ?= 0)%Z = Datatypes.Eq <-> x = 0%Z) in |- *. + apply Zcompare_Eq_iff_eq. + + (***) + intro. + cut (exists h : nat, Zabs_nat x = S h). + intro. + case H3. + rewrite H. + exact O_S. + + change (x < 0)%Z in H2. + cut (0 > x)%Z. + intro. + cut (exists p : positive, (0 + - x)%Z = Zpos p). + simpl in |- *. + intro. + case H4. + intros. + cut (exists q : positive, x = Zneg q). + intro. + case H6. + intros. + rewrite H7. + unfold Zabs_nat in |- *. + generalize x1. + exact ZL4. + cut (x = (- Zpos x0)%Z). + simpl in |- *. + intro. + exists x0. + assumption. + cut ((- - x)%Z = x). + intro. + rewrite <- H6. + exact (f_equal Zopp H5). + apply Zopp_involutive. + apply Zcompare_Gt_spec. + assumption. + apply Zlt_gt. + assumption. + + (***) + intro. + cut (exists h : nat, Zabs_nat x = S h). + intro. + case H3. + rewrite H. + exact O_S. + + cut (exists p : positive, (x + - (0))%Z = Zpos p). + simpl in |- *. + rewrite Zplus_0_r. + intro. + case H3. + intros. + rewrite H4. + unfold Zabs_nat in |- *. + generalize x0. + exact ZL4. + apply Zcompare_Gt_spec. + assumption. + + (***) + cut ((x < 0)%Z \/ (0 < x)%Z). + intro. + apply + or_ind with (A := (x < 0)%Z) (B := (0 < x)%Z) (P := (x < 0)%Z \/ (x > 0)%Z). + intro. + left. + assumption. + intro. + right. + apply Zlt_gt. + assumption. + assumption. + apply not_Zeq. + assumption. +Qed. + +Lemma absolu_2 : forall x : Z, x <> 0%Z -> Zabs_nat x <> 0. (*QF*) +Proof. + intros. + intro. + apply H. + apply absolu_1. + assumption. +Qed. + + + + +Lemma absolu_inject_nat : forall n : nat, Zabs_nat (Z_of_nat n) = n. +Proof. + simple induction n; simpl in |- *. + reflexivity. + intros. + apply nat_of_P_o_P_of_succ_nat_eq_succ. +Qed. + + +Lemma eq_inj : forall m n : nat, m = n :>Z -> m = n. +Proof. + intros. + generalize (f_equal Zabs_nat H). + intro. + rewrite (absolu_inject_nat m) in H0. + rewrite (absolu_inject_nat n) in H0. + assumption. +Qed. + +Lemma lt_inj : forall m n : nat, (m < n)%Z -> m < n. +Proof. + intros. + omega. +Qed. + +Lemma le_inj : forall m n : nat, (m <= n)%Z -> m <= n. +Proof. + intros. + omega. +Qed. + + +Lemma inject_nat_S_inf : forall x : Z, (0 < x)%Z -> {n : nat | x = S n}. +Proof. + intros [| p| p] Hp; try discriminate Hp. + exists (pred (nat_of_P p)). + rewrite S_predn. + symmetry in |- *; apply ZL9. + clear Hp; + apply sym_not_equal; apply lt_O_neq; apply lt_O_nat_of_P. +Qed. + + + +Lemma le_absolu : + forall x y : Z, + (0 <= x)%Z -> (0 <= y)%Z -> (x <= y)%Z -> Zabs_nat x <= Zabs_nat y. +Proof. + intros [| x| x] [| y| y] Hx Hy Hxy; + apply le_O_n || + (try + match goal with + | id1:(0 <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= 0)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + end). + simpl in |- *. + apply le_inj. + do 2 rewrite ZL9. + assumption. +Qed. + +Lemma lt_absolu : + forall x y : Z, + (0 <= x)%Z -> (0 <= y)%Z -> (x < y)%Z -> Zabs_nat x < Zabs_nat y. +Proof. + intros [| x| x] [| y| y] Hx Hy Hxy; inversion Hxy; + try + match goal with + | id1:(0 <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= 0)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + end; simpl in |- *; apply lt_inj; repeat rewrite ZL9; + assumption. +Qed. + +Lemma absolu_plus : + forall x y : Z, + (0 <= x)%Z -> (0 <= y)%Z -> Zabs_nat (x + y) = Zabs_nat x + Zabs_nat y. +Proof. + intros [| x| x] [| y| y] Hx Hy; trivial; + try + match goal with + | id1:(0 <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= 0)%Z |- _ => + apply False_ind; apply id1; constructor + | id1:(Zpos _ <= Zneg _)%Z |- _ => + apply False_ind; apply id1; constructor + end. + rewrite <- BinInt.Zpos_plus_distr. + unfold Zabs_nat in |- *. + apply nat_of_P_plus_morphism. +Qed. + +Lemma pred_absolu : + forall x : Z, (0 < x)%Z -> pred (Zabs_nat x) = Zabs_nat (x - 1). +Proof. + intros x Hx. + generalize (Z_lt_lt_S_eq_dec 0 x Hx); simpl in |- *; intros [H1| H1]; + [ replace (Zabs_nat x) with (Zabs_nat (x - 1 + 1)); + [ idtac | apply f_equal with Z; auto with zarith ]; + rewrite absolu_plus; + [ unfold Zabs_nat at 2, nat_of_P, Piter_op in |- *; omega + | auto with zarith + | intro; discriminate ] + | rewrite <- H1; reflexivity ]. +Qed. + +Definition pred_nat : forall (x : Z) (Hx : (0 < x)%Z), nat. +intros [| px| px] Hx; try abstract (discriminate Hx). +exact (pred (nat_of_P px)). +Defined. + +Lemma pred_nat_equal : + forall (x : Z) (Hx1 Hx2 : (0 < x)%Z), pred_nat x Hx1 = pred_nat x Hx2. +Proof. + intros [| px| px] Hx1 Hx2; try (discriminate Hx1); trivial. +Qed. + +Let pred_nat_unfolded_subproof px : + Pos.to_nat px <> 0. +Proof. +apply sym_not_equal; apply lt_O_neq; apply lt_O_nat_of_P. +Qed. + +Lemma pred_nat_unfolded : + forall (x : Z) (Hx : (0 < x)%Z), x = S (pred_nat x Hx). +Proof. + intros [| px| px] Hx; try discriminate Hx. + unfold pred_nat in |- *. + rewrite S_predn. + symmetry in |- *; apply ZL9. + clear Hx; apply pred_nat_unfolded_subproof. +Qed. + +Lemma absolu_pred_nat : + forall (m : Z) (Hm : (0 < m)%Z), S (pred_nat m Hm) = Zabs_nat m. +Proof. + intros [| px| px] Hx; try discriminate Hx. + unfold pred_nat in |- *. + rewrite S_predn. + reflexivity. + apply pred_nat_unfolded_subproof. +Qed. + +Lemma pred_nat_absolu : + forall (m : Z) (Hm : (0 < m)%Z), pred_nat m Hm = Zabs_nat (m - 1). +Proof. + intros [| px| px] Hx; try discriminate Hx. + unfold pred_nat in |- *. + rewrite <- pred_absolu; reflexivity || assumption. +Qed. + +Lemma minus_pred_nat : + forall (n m : Z) (Hn : (0 < n)%Z) (Hm : (0 < m)%Z) (Hnm : (0 < n - m)%Z), + S (pred_nat n Hn) - S (pred_nat m Hm) = S (pred_nat (n - m) Hnm). +Proof. + intros. + simpl in |- *. + destruct n; try discriminate Hn. + destruct m; try discriminate Hm. + unfold pred_nat at 1 2 in |- *. + rewrite minus_pred; try apply lt_O_nat_of_P. + apply eq_inj. + rewrite <- pred_nat_unfolded. + rewrite Znat.inj_minus1. + repeat rewrite ZL9. + reflexivity. + apply le_inj. + apply Zlt_le_weak. + repeat rewrite ZL9. + apply Zlt_O_minus_lt. + assumption. +Qed. + + +(*###########################################################################*) +(** Properties of Zsgn *) +(*###########################################################################*) + + +Lemma Zsgn_1 : + forall x : Z, {Zsgn x = 0%Z} + {Zsgn x = 1%Z} + {Zsgn x = (-1)%Z}. (*QF*) +Proof. + intros. + case x. + left. + left. + unfold Zsgn in |- *. + reflexivity. + intro. + simpl in |- *. + left. + right. + reflexivity. + intro. + right. + simpl in |- *. + reflexivity. +Qed. + + +Lemma Zsgn_2 : forall x : Z, Zsgn x = 0%Z -> x = 0%Z. (*QF*) +Proof. + intros [| p1| p1]; simpl in |- *; intro H; constructor || discriminate H. +Qed. + + +Lemma Zsgn_3 : forall x : Z, x <> 0%Z -> Zsgn x <> 0%Z. (*QF*) +Proof. + intro. + case x. + intros. + apply False_ind. + apply H. + reflexivity. + intros. + simpl in |- *. + discriminate. + intros. + simpl in |- *. + discriminate. +Qed. + + + + +Theorem Zsgn_4 : forall a : Z, a = (Zsgn a * Zabs_nat a)%Z. (*QF*) +Proof. + intro. + case a. + simpl in |- *. + reflexivity. + intro. + unfold Zsgn in |- *. + unfold Zabs_nat in |- *. + rewrite Zmult_1_l. + symmetry in |- *. + apply ZL9. + intros. + unfold Zsgn in |- *. + unfold Zabs_nat in |- *. + rewrite ZL9. + constructor. +Qed. + + +Theorem Zsgn_5 : + forall a b x y : Z, + x <> 0%Z -> + y <> 0%Z -> + (Zsgn a * x)%Z = (Zsgn b * y)%Z -> (Zsgn a * y)%Z = (Zsgn b * x)%Z. (*QF*) +Proof. + intros a b x y H H0. + case a. + + case b. + simpl in |- *. + trivial. + + intro. + unfold Zsgn in |- *. + intro. + rewrite Zmult_1_l in H1. + simpl in H1. + apply False_ind. + apply H0. + symmetry in |- *. + assumption. + intro. + unfold Zsgn in |- *. + intro. + apply False_ind. + apply H0. + apply Zopp_inj. + simpl in |- *. + transitivity (-1 * y)%Z. + constructor. + transitivity (0 * x)%Z. + symmetry in |- *. + assumption. + simpl in |- *. + reflexivity. + intro. + unfold Zsgn at 1 in |- *. + unfold Zsgn at 2 in |- *. + intro. + transitivity y. + rewrite Zmult_1_l. + reflexivity. + transitivity (Zsgn b * (Zsgn b * y))%Z. + case (Zsgn_1 b). + intro. + case s. + intro. + apply False_ind. + apply H. + rewrite e in H1. + change ((1 * x)%Z = 0%Z) in H1. + rewrite Zmult_1_l in H1. + assumption. + intro. + rewrite e. + rewrite Zmult_1_l. + rewrite Zmult_1_l. + reflexivity. + intro. + rewrite e. + ring. + rewrite Zmult_1_l in H1. + rewrite H1. + reflexivity. + intro. + unfold Zsgn at 1 in |- *. + unfold Zsgn at 2 in |- *. + intro. + transitivity (Zsgn b * (-1 * (Zsgn b * y)))%Z. + case (Zsgn_1 b). + intros. + case s. + intro. + apply False_ind. + apply H. + apply Zopp_inj. + transitivity (-1 * x)%Z. + ring. + unfold Zopp in |- *. + rewrite e in H1. + transitivity (0 * y)%Z. + assumption. + simpl in |- *. + reflexivity. + intro. + rewrite e. + ring. + intro. + rewrite e. + ring. + rewrite <- H1. + ring. +Qed. + +Lemma Zsgn_6 : forall x : Z, x = 0%Z -> Zsgn x = 0%Z. +Proof. + intros. + rewrite H. + simpl in |- *. + reflexivity. +Qed. + + +Lemma Zsgn_7 : forall x : Z, (x > 0)%Z -> Zsgn x = 1%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + apply (Zlt_irrefl 0). + Flip. + intros. + simpl in |- *. + reflexivity. + intros. + apply False_ind. + apply (Zlt_irrefl (Zneg p)). + apply Zlt_trans with 0%Z. + constructor. + Flip. +Qed. + + +Lemma Zsgn_7' : forall x : Z, (0 < x)%Z -> Zsgn x = 1%Z. +Proof. + intros; apply Zsgn_7; Flip. +Qed. + + +Lemma Zsgn_8 : forall x : Z, (x < 0)%Z -> Zsgn x = (-1)%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + apply (Zlt_irrefl 0). + assumption. + intros. + apply False_ind. + apply (Zlt_irrefl 0). + apply Zlt_trans with (Zpos p). + constructor. + assumption. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zsgn_9 : forall x : Z, Zsgn x = 1%Z -> (0 < x)%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + simpl in H. + discriminate. + intros. + constructor. + intros. + apply False_ind. + discriminate. +Qed. + +Lemma Zsgn_10 : forall x : Z, Zsgn x = (-1)%Z -> (x < 0)%Z. +Proof. + intro. + case x. + intro. + apply False_ind. + discriminate. + intros. + apply False_ind. + discriminate. + intros. + constructor. +Qed. + +Lemma Zsgn_11 : forall x : Z, (Zsgn x < 0)%Z -> (x < 0)%Z. +Proof. + intros. + apply Zsgn_10. + case (Zsgn_1 x). + intro. + apply False_ind. + case s. + intro. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + apply (H0 e). + intro. + rewrite e in H. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + discriminate. + trivial. +Qed. + +Lemma Zsgn_12 : forall x : Z, (0 < Zsgn x)%Z -> (0 < x)%Z. +Proof. + intros. + apply Zsgn_9. + case (Zsgn_1 x). + intro. + case s. + intro. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + generalize (sym_eq e). + intro. + apply False_ind. + apply (H0 H1). + trivial. + intro. + rewrite e in H. + generalize (Zorder.Zlt_not_eq _ _ H). + intro. + apply False_ind. + discriminate. +Qed. + +Lemma Zsgn_13 : forall x : Z, (0 <= Zsgn x)%Z -> (0 <= x)%Z. +Proof. + intros. + case (Z_le_lt_eq_dec 0 (Zsgn x) H). + intro. + apply Zlt_le_weak. + apply Zsgn_12. + assumption. + intro. + assert (x = 0%Z). + apply Zsgn_2. + symmetry in |- *. + assumption. + rewrite H0. + apply Zle_refl. +Qed. + +Lemma Zsgn_14 : forall x : Z, (Zsgn x <= 0)%Z -> (x <= 0)%Z. +Proof. + intros. + case (Z_le_lt_eq_dec (Zsgn x) 0 H). + intro. + apply Zlt_le_weak. + apply Zsgn_11. + assumption. + intro. + assert (x = 0%Z). + apply Zsgn_2. + assumption. + rewrite H0. + apply Zle_refl. +Qed. + +Lemma Zsgn_15 : forall x y : Z, Zsgn (x * y) = (Zsgn x * Zsgn y)%Z. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; constructor. +Qed. + +Lemma Zsgn_16 : + forall x y : Z, + Zsgn (x * y) = 1%Z -> {(0 < x)%Z /\ (0 < y)%Z} + {(x < 0)%Z /\ (y < 0)%Z}. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + try discriminate H; [ left | right ]; repeat split. +Qed. + +Lemma Zsgn_17 : + forall x y : Z, + Zsgn (x * y) = (-1)%Z -> {(0 < x)%Z /\ (y < 0)%Z} + {(x < 0)%Z /\ (0 < y)%Z}. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + try discriminate H; [ left | right ]; repeat split. +Qed. + +Lemma Zsgn_18 : forall x y : Z, Zsgn (x * y) = 0%Z -> {x = 0%Z} + {y = 0%Z}. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + try discriminate H; [ left | right | right ]; constructor. +Qed. + + + +Lemma Zsgn_19 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 < x + y)%Z. +Proof. + Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + discriminate H || (constructor || apply Zsgn_12; assumption). +Qed. + +Lemma Zsgn_20 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x + y < 0)%Z. +Proof. + Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + discriminate H || (constructor || apply Zsgn_11; assumption). +Qed. + + +Lemma Zsgn_21 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= x)%Z. +Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_22 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x <= 0)%Z. +Proof. + Proof. + intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_23 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= y)%Z. +Proof. + intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros H H0; discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_24 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (y <= 0)%Z. +Proof. + intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros H H0; discriminate H || discriminate H0. +Qed. + +Lemma Zsgn_25 : forall x : Z, Zsgn (- x) = (- Zsgn x)%Z. +Proof. + intros [| p1| p1]; simpl in |- *; reflexivity. +Qed. + + +Lemma Zsgn_26 : forall x : Z, (0 < x)%Z -> (0 < Zsgn x)%Z. +Proof. + intros [| p| p] Hp; trivial. +Qed. + +Lemma Zsgn_27 : forall x : Z, (x < 0)%Z -> (Zsgn x < 0)%Z. +Proof. + intros [| p| p] Hp; trivial. +Qed. + +Hint Resolve Zsgn_1 Zsgn_2 Zsgn_3 Zsgn_4 Zsgn_5 Zsgn_6 Zsgn_7 Zsgn_7' Zsgn_8 + Zsgn_9 Zsgn_10 Zsgn_11 Zsgn_12 Zsgn_13 Zsgn_14 Zsgn_15 Zsgn_16 Zsgn_17 + Zsgn_18 Zsgn_19 Zsgn_20 Zsgn_21 Zsgn_22 Zsgn_23 Zsgn_24 Zsgn_25 Zsgn_26 + Zsgn_27: zarith. + +(*###########################################################################*) +(** Properties of Zabs *) +(*###########################################################################*) + +Lemma Zabs_1 : forall z p : Z, (Zabs z < p)%Z -> (z < p)%Z /\ (- p < z)%Z. +Proof. + intros z p. + case z. + intros. + simpl in H. + split. + assumption. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + replace (-1)%Z with (Zpred 0). + apply Zlt_pred. + simpl; trivial. + ring_simplify (-1 * - p)%Z (-1 * 0)%Z. + apply Zlt_gt. + assumption. + + intros. + simpl in H. + split. + assumption. + apply Zlt_trans with (m := 0%Z). + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + replace (-1)%Z with (Zpred 0). + apply Zlt_pred. + simpl; trivial. + ring_simplify (-1 * - p)%Z (-1 * 0)%Z. + apply Zlt_gt. + apply Zlt_trans with (m := Zpos p0). + constructor. + assumption. + constructor. + + intros. + simpl in H. + split. + apply Zlt_trans with (m := Zpos p0). + constructor. + assumption. + + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + replace (-1)%Z with (Zpred 0). + apply Zlt_pred. + simpl;trivial. + ring_simplify (-1 * - p)%Z. + replace (-1 * Zneg p0)%Z with (- Zneg p0)%Z. + replace (- Zneg p0)%Z with (Zpos p0). + apply Zlt_gt. + assumption. + symmetry in |- *. + apply Zopp_neg. + rewrite Zopp_mult_distr_l_reverse with (n := 1%Z). + simpl in |- *. + constructor. +Qed. + + +Lemma Zabs_2 : forall z p : Z, (Zabs z > p)%Z -> (z > p)%Z \/ (- p > z)%Z. +Proof. + intros z p. + case z. + intros. + simpl in H. + left. + assumption. + + intros. + simpl in H. + left. + assumption. + + intros. + simpl in H. + right. + apply Zlt_gt. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + ring_simplify (-1 * - p)%Z. + replace (-1 * Zneg p0)%Z with (Zpos p0). + assumption. + reflexivity. +Qed. + +Lemma Zabs_3 : forall z p : Z, (z < p)%Z /\ (- p < z)%Z -> (Zabs z < p)%Z. +Proof. + intros z p. + case z. + intro. + simpl in |- *. + elim H. + intros. + assumption. + + intros. + elim H. + intros. + simpl in |- *. + assumption. + + intros. + elim H. + intros. + simpl in |- *. + apply Zgt_mult_conv_absorb_l with (a := (-1)%Z). + constructor. + replace (-1 * Zpos p0)%Z with (Zneg p0). + replace (-1 * p)%Z with (- p)%Z. + apply Zlt_gt. + assumption. + ring. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zabs_4 : forall z p : Z, (Zabs z < p)%Z -> (- p < z < p)%Z. +Proof. + intros. + split. + apply proj2 with (A := (z < p)%Z). + apply Zabs_1. + assumption. + apply proj1 with (B := (- p < z)%Z). + apply Zabs_1. + assumption. +Qed. + + +Lemma Zabs_5 : forall z p : Z, (Zabs z <= p)%Z -> (- p <= z <= p)%Z. +Proof. + intros. + split. + replace (- p)%Z with (Zsucc (- Zsucc p)). + apply Zlt_le_succ. + apply proj2 with (A := (z < Zsucc p)%Z). + apply Zabs_1. + apply Zle_lt_succ. + assumption. + unfold Zsucc in |- *. + ring. + apply Zlt_succ_le. + apply proj1 with (B := (- Zsucc p < z)%Z). + apply Zabs_1. + apply Zle_lt_succ. + assumption. +Qed. + +Lemma Zabs_6 : forall z p : Z, (Zabs z <= p)%Z -> (z <= p)%Z. +Proof. + intros. + apply proj2 with (A := (- p <= z)%Z). + apply Zabs_5. + assumption. +Qed. + +Lemma Zabs_7 : forall z p : Z, (Zabs z <= p)%Z -> (- p <= z)%Z. +Proof. + intros. + apply proj1 with (B := (z <= p)%Z). + apply Zabs_5. + assumption. +Qed. + +Lemma Zabs_8 : forall z p : Z, (- p <= z <= p)%Z -> (Zabs z <= p)%Z. +Proof. + intros. + apply Zlt_succ_le. + apply Zabs_3. + elim H. + intros. + split. + apply Zle_lt_succ. + assumption. + apply Zlt_le_trans with (m := (- p)%Z). + apply Zgt_lt. + apply Zlt_opp. + apply Zlt_succ. + assumption. +Qed. + +Lemma Zabs_min : forall z : Z, Zabs z = Zabs (- z). +Proof. + intro. + case z. + simpl in |- *. + reflexivity. + intro. + simpl in |- *. + reflexivity. + intro. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zabs_9 : + forall z p : Z, (0 <= p)%Z -> (p < z)%Z \/ (z < - p)%Z -> (p < Zabs z)%Z. +Proof. + intros. + case H0. + intro. + replace (Zabs z) with z. + assumption. + symmetry in |- *. + apply Zabs_eq. + apply Zlt_le_weak. + apply Zle_lt_trans with (m := p). + assumption. + assumption. + intro. + cut (Zabs z = (- z)%Z). + intro. + rewrite H2. + apply Zmin_cancel_Zlt. + ring_simplify (- - z)%Z. + assumption. + rewrite Zabs_min. + apply Zabs_eq. + apply Zlt_le_weak. + apply Zle_lt_trans with (m := p). + assumption. + apply Zmin_cancel_Zlt. + ring_simplify (- - z)%Z. + assumption. +Qed. + +Lemma Zabs_10 : forall z : Z, (0 <= Zabs z)%Z. +Proof. + intro. + case (Z_zerop z). + intro. + rewrite e. + simpl in |- *. + apply Zle_refl. + intro. + case (not_Zeq z 0 n). + intro. + apply Zlt_le_weak. + apply Zabs_9. + apply Zle_refl. + simpl in |- *. + right. + assumption. + intro. + apply Zlt_le_weak. + apply Zabs_9. + apply Zle_refl. + simpl in |- *. + left. + assumption. +Qed. + +Lemma Zabs_11 : forall z : Z, z <> 0%Z -> (0 < Zabs z)%Z. +Proof. + intros. + apply Zabs_9. + apply Zle_refl. + simpl in |- *. + apply not_Zeq. + intro. + apply H. + symmetry in |- *. + assumption. +Qed. + +Lemma Zabs_12 : forall z m : Z, (m < Zabs z)%Z -> {(m < z)%Z} + {(z < - m)%Z}. +Proof. + intros [| p| p] m; simpl in |- *; intros H; + [ left | left | right; apply Zmin_cancel_Zlt; rewrite Zopp_involutive ]; + assumption. +Qed. + +Lemma Zabs_mult : forall z p : Z, Zabs (z * p) = (Zabs z * Zabs p)%Z. +Proof. + intros. + case z. + simpl in |- *. + reflexivity. + case p. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. + case p. + intro. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zabs_plus : forall z p : Z, (Zabs (z + p) <= Zabs z + Zabs p)%Z. +Proof. + intros. + case z. + simpl in |- *. + apply Zle_refl. + case p. + intro. + simpl in |- *. + apply Zle_refl. + intros. + simpl in |- *. + apply Zle_refl. + intros. + unfold Zabs at 2 in |- *. + unfold Zabs at 2 in |- *. + apply Zabs_8. + split. + apply Zplus_le_reg_l with (Zpos p1 - Zneg p0)%Z. + replace (Zpos p1 - Zneg p0 + - (Zpos p1 + Zpos p0))%Z with + (- (Zpos p0 + Zneg p0))%Z. + replace (Zpos p1 - Zneg p0 + (Zpos p1 + Zneg p0))%Z with (2 * Zpos p1)%Z. + replace (- (Zpos p0 + Zneg p0))%Z with 0%Z. + apply Zmult_gt_0_le_0_compat. + constructor. + apply Zlt_le_weak. + constructor. + rewrite <- Zopp_neg with p0. + ring. + ring. + ring. + apply Zplus_le_compat. + apply Zle_refl. + apply Zlt_le_weak. + constructor. + + case p. + simpl in |- *. + intro. + apply Zle_refl. + intros. + unfold Zabs at 2 in |- *. + unfold Zabs at 2 in |- *. + apply Zabs_8. + split. + apply Zplus_le_reg_l with (Zpos p1 + Zneg p0)%Z. + replace (Zpos p1 + Zneg p0 + - (Zpos p1 + Zpos p0))%Z with + (Zneg p0 - Zpos p0)%Z. + replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with 0%Z. + apply Zplus_le_reg_l with (Zpos p0). + replace (Zpos p0 + (Zneg p0 - Zpos p0))%Z with (Zneg p0). + simpl in |- *. + apply Zlt_le_weak. + constructor. + ring. + replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with + (Zpos p1 + Zneg p1 + (Zpos p0 + Zneg p0))%Z. + replace 0%Z with (0 + 0)%Z. + apply Zplus_eq_compat. + rewrite <- Zopp_neg with p1. + ring. + rewrite <- Zopp_neg with p0. + ring. + simpl in |- *. + constructor. + ring. + ring. + apply Zplus_le_compat. + apply Zlt_le_weak. + constructor. + apply Zle_refl. + intros. + simpl in |- *. + apply Zle_refl. +Qed. + +Lemma Zabs_neg : forall z : Z, (z <= 0)%Z -> Zabs z = (- z)%Z. +Proof. + intro. + case z. + simpl in |- *. + intro. + reflexivity. + intros. + apply False_ind. + apply H. + simpl in |- *. + reflexivity. + intros. + simpl in |- *. + reflexivity. +Qed. + +Lemma Zle_Zabs: forall z, (z <= Zabs z)%Z. +Proof. + intros [|z|z]; simpl; auto with zarith; apply Zle_neg_pos. +Qed. + +Hint Resolve Zabs_1 Zabs_2 Zabs_3 Zabs_4 Zabs_5 Zabs_6 Zabs_7 Zabs_8 Zabs_9 + Zabs_10 Zabs_11 Zabs_12 Zabs_min Zabs_neg Zabs_mult Zabs_plus Zle_Zabs: zarith. + + +(*###########################################################################*) +(** Induction on Z *) +(*###########################################################################*) + +Lemma Zind : + forall (P : Z -> Prop) (p : Z), + P p -> + (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros P p. + intro. + intro. + cut (forall q : Z, (p <= q)%Z -> exists k : nat, q = (p + k)%Z). + intro. + cut (forall k : nat, P (p + k)%Z). + intro. + intros. + cut (exists k : nat, q = (p + Z_of_nat k)%Z). + intro. + case H4. + intros. + rewrite H5. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + ring_simplify (p + 0)%Z. + assumption. + replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (Z_of_nat 0). + ring_simplify (- p + (p + Z_of_nat k))%Z. + apply Znat.inj_le. + apply le_O_n. + ring_simplify; auto with arith. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + ring. + intros. + cut (exists k : nat, (q - p)%Z = Z_of_nat k). + intro. + case H2. + intro k. + intros. + exists k. + apply Zplus_reg_l with (n := (- p)%Z). + replace (- p + q)%Z with (q - p)%Z. + rewrite H3. + ring. + ring. + apply Z_of_nat_complete. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zrec : + forall (P : Z -> Set) (p : Z), + P p -> + (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros F p. + intro. + intro. + cut (forall q : Z, (p <= q)%Z -> {k : nat | q = (p + k)%Z}). + intro. + cut (forall k : nat, F (p + k)%Z). + intro. + intros. + cut {k : nat | q = (p + Z_of_nat k)%Z}. + intro. + case H4. + intros. + rewrite e. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + rewrite Zplus_0_r. + assumption. + replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (Z_of_nat 0). + replace (- p + (p + Z_of_nat k))%Z with (Z_of_nat k). + apply Znat.inj_le. + apply le_O_n. + rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. + rewrite Zplus_opp_l; reflexivity. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + apply Zplus_assoc_reverse. + intros. + cut {k : nat | (q - p)%Z = Z_of_nat k}. + intro H2. + case H2. + intro k. + intros. + exists k. + apply Zplus_reg_l with (n := (- p)%Z). + replace (- p + q)%Z with (q - p)%Z. + rewrite e. + rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. + unfold Zminus in |- *. + apply Zplus_comm. + apply Z_of_nat_complete_inf. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zrec_down : + forall (P : Z -> Set) (p : Z), + P p -> + (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) -> + forall q : Z, (q <= p)%Z -> P q. +Proof. + intros F p. + intro. + intro. + cut (forall q : Z, (q <= p)%Z -> {k : nat | q = (p - k)%Z}). + intro. + cut (forall k : nat, F (p - k)%Z). + intro. + intros. + cut {k : nat | q = (p - Z_of_nat k)%Z}. + intro. + case H4. + intros. + rewrite e. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + replace (p - 0)%Z with p. + assumption. + unfold Zminus in |- *. + unfold Zopp in |- *. + rewrite Zplus_0_r; reflexivity. + replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (- Z_of_nat 0)%Z. + replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z. + apply Zge_le. + apply Zge_opp. + apply Znat.inj_le. + apply le_O_n. + unfold Zminus in |- *; rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity. + rewrite Zplus_opp_l; reflexivity. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + unfold Zminus at 1 2 in |- *. + rewrite Zplus_assoc_reverse. + rewrite <- Zopp_plus_distr. + reflexivity. + intros. + cut {k : nat | (p - q)%Z = Z_of_nat k}. + intro. + case H2. + intro k. + intros. + exists k. + apply Zopp_inj. + apply Zplus_reg_l with (n := p). + replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). + rewrite <- e. + reflexivity. + unfold Zminus in |- *. + rewrite Zopp_plus_distr. + rewrite Zplus_assoc. + rewrite Zplus_opp_r. + rewrite Zopp_involutive. + reflexivity. + apply Z_of_nat_complete_inf. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zind_down : + forall (P : Z -> Prop) (p : Z), + P p -> + (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) -> + forall q : Z, (q <= p)%Z -> P q. +Proof. + intros F p. + intro. + intro. + cut (forall q : Z, (q <= p)%Z -> exists k : nat, q = (p - k)%Z). + intro. + cut (forall k : nat, F (p - k)%Z). + intro. + intros. + cut (exists k : nat, q = (p - Z_of_nat k)%Z). + intro. + case H4. + intros x e. + rewrite e. + apply H2. + apply H1. + assumption. + intro. + induction k as [| k Hreck]. + simpl in |- *. + replace (p - 0)%Z with p. + assumption. + ring. + replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z. + apply H0. + apply Zplus_le_reg_l with (p := (- p)%Z). + replace (- p + p)%Z with (- Z_of_nat 0)%Z. + replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z. + apply Zge_le. + apply Zge_opp. + apply Znat.inj_le. + apply le_O_n. + ring. + ring_simplify; auto with arith. + assumption. + rewrite (Znat.inj_S k). + unfold Zsucc in |- *. + ring. + intros. + cut (exists k : nat, (p - q)%Z = Z_of_nat k). + intro. + case H2. + intro k. + intros. + exists k. + apply Zopp_inj. + apply Zplus_reg_l with (n := p). + replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). + rewrite <- H3. + ring. + ring. + apply Z_of_nat_complete. + unfold Zminus in |- *. + apply Zle_left. + assumption. +Qed. + +Lemma Zrec_wf : + forall (P : Z -> Set) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros P p WF_ind_step q Hq. + cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y). + intro. + apply (H (Zsucc q)). + apply Zle_le_succ. + assumption. + + split; [ assumption | exact (Zlt_succ q) ]. + + intros x0 Hx0; generalize Hx0; pattern x0 in |- *. + apply Zrec with (p := p). + intros. + absurd (p <= p)%Z. + apply Zgt_not_le. + apply Zgt_le_trans with (m := y). + apply Zlt_gt. + elim H. + intros. + assumption. + elim H. + intros. + assumption. + apply Zle_refl. + + intros. + apply WF_ind_step. + intros. + apply (H0 H). + split. + elim H2. + intros. + assumption. + apply Zlt_le_trans with y. + elim H2. + intros. + assumption. + apply Zgt_succ_le. + apply Zlt_gt. + elim H1. + intros. + unfold Zsucc in |- *. + assumption. + assumption. +Qed. + +Lemma Zrec_wf2 : + forall (q : Z) (P : Z -> Set) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + (p <= q)%Z -> P q. +Proof. + intros. + apply Zrec_wf with (p := p). + assumption. + assumption. +Qed. + +Lemma Zrec_wf_double : + forall (P : Z -> Z -> Set) (p0 q0 : Z), + (forall n m : Z, + (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) -> + (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) -> + forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q. +Proof. + intros P p0 q0 Hrec p. + intros. + generalize q H. + pattern p in |- *. + apply Zrec_wf with (p := p0). + intros p1 H1. + intros. + pattern q1 in |- *. + apply Zrec_wf with (p := q0). + intros q2 H3. + apply Hrec. + intros. + apply H1. + assumption. + assumption. + intros. + apply H3. + assumption. + assumption. + assumption. +Qed. + +Lemma Zind_wf : + forall (P : Z -> Prop) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + forall q : Z, (p <= q)%Z -> P q. +Proof. + intros P p WF_ind_step q Hq. + cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y). + intro. + apply (H (Zsucc q)). + apply Zle_le_succ. + assumption. + + split; [ assumption | exact (Zlt_succ q) ]. + + intros x0 Hx0; generalize Hx0; pattern x0 in |- *. + apply Zind with (p := p). + intros. + absurd (p <= p)%Z. + apply Zgt_not_le. + apply Zgt_le_trans with (m := y). + apply Zlt_gt. + elim H. + intros. + assumption. + elim H. + intros. + assumption. + apply Zle_refl. + + intros. + apply WF_ind_step. + intros. + apply (H0 H). + split. + elim H2. + intros. + assumption. + apply Zlt_le_trans with y. + elim H2. + intros. + assumption. + apply Zgt_succ_le. + apply Zlt_gt. + elim H1. + intros. + unfold Zsucc in |- *. + assumption. + assumption. +Qed. + +Lemma Zind_wf2 : + forall (q : Z) (P : Z -> Prop) (p : Z), + (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) -> + (p <= q)%Z -> P q. +Proof. + intros. + apply Zind_wf with (p := p). + assumption. + assumption. +Qed. + +Lemma Zind_wf_double : + forall (P : Z -> Z -> Prop) (p0 q0 : Z), + (forall n m : Z, + (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) -> + (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) -> + forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q. +Proof. + intros P p0 q0 Hrec p. + intros. + generalize q H. + pattern p in |- *. + apply Zind_wf with (p := p0). + intros p1 H1. + intros. + pattern q1 in |- *. + apply Zind_wf with (p := q0). + intros q2 H3. + apply Hrec. + intros. + apply H1. + assumption. + assumption. + intros. + apply H3. + assumption. + assumption. + assumption. +Qed. + +(*###########################################################################*) +(** Properties of Zmax *) +(*###########################################################################*) + +Definition Zmax (n m : Z) := (n + m - Zmin n m)%Z. + +Lemma ZmaxSS : forall n m : Z, (Zmax n m + 1)%Z = Zmax (n + 1) (m + 1). +Proof. + intros. + unfold Zmax in |- *. + replace (Zmin (n + 1) (m + 1)) with (Zmin n m + 1)%Z. + ring. + symmetry in |- *. + change (Zmin (Zsucc n) (Zsucc m) = Zsucc (Zmin n m)) in |- *. + symmetry in |- *. + apply Zmin_SS. +Qed. + +Lemma Zle_max_l : forall n m : Z, (n <= Zmax n m)%Z. +Proof. + intros. + unfold Zmax in |- *. + apply Zplus_le_reg_l with (p := (- n + Zmin n m)%Z). + ring_simplify (- n + Zmin n m + n)%Z. + ring_simplify (- n + Zmin n m + (n + m - Zmin n m))%Z. + apply Zle_min_r. +Qed. + +Lemma Zle_max_r : forall n m : Z, (m <= Zmax n m)%Z. +Proof. + intros. + unfold Zmax in |- *. + apply Zplus_le_reg_l with (p := (- m + Zmin n m)%Z). + ring_simplify (- m + Zmin n m + m)%Z. + ring_simplify (- m + Zmin n m + (n + m - Zmin n m))%Z. + apply Zle_min_l. +Qed. + + +Lemma Zmin_or_informative : forall n m : Z, {Zmin n m = n} + {Zmin n m = m}. +Proof. + intros. + case (Z_lt_ge_dec n m). + unfold Zmin in |- *. + unfold Zlt in |- *. + intro z. + rewrite z. + left. + reflexivity. + intro. + cut ({(n > m)%Z} + {n = m :>Z}). + intro. + case H. + intros z0. + unfold Zmin in |- *. + unfold Zgt in z0. + rewrite z0. + right. + reflexivity. + intro. + rewrite e. + right. + apply Zmin_n_n. + cut ({(m < n)%Z} + {m = n :>Z}). + intro. + elim H. + intro. + left. + apply Zlt_gt. + assumption. + intro. + right. + symmetry in |- *. + assumption. + apply Z_le_lt_eq_dec. + apply Zge_le. + assumption. +Qed. + +Lemma Zmax_case : forall (n m : Z) (P : Z -> Set), P n -> P m -> P (Zmax n m). +Proof. + intros. + unfold Zmax in |- *. + case Zmin_or_informative with (n := n) (m := m). + intro. + rewrite e. + cut ((n + m - n)%Z = m). + intro. + rewrite H1. + assumption. + ring. + intro. + rewrite e. + cut ((n + m - m)%Z = n). + intro. + rewrite H1. + assumption. + ring. +Qed. + +Lemma Zmax_or_informative : forall n m : Z, {Zmax n m = n} + {Zmax n m = m}. +Proof. + intros. + unfold Zmax in |- *. + case Zmin_or_informative with (n := n) (m := m). + intro. + rewrite e. + right. + ring. + intro. + rewrite e. + left. + ring. +Qed. + +Lemma Zmax_n_n : forall n : Z, Zmax n n = n. +Proof. + intros. + unfold Zmax in |- *. + rewrite (Zmin_n_n n). + ring. +Qed. + +Hint Resolve ZmaxSS Zle_max_r Zle_max_l Zmax_n_n: zarith. + +(*###########################################################################*) +(** Properties of Arity *) +(*###########################################################################*) + +Lemma Zeven_S : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x + 1). +Proof. + exact Zeven.Zeven_Sn. +Qed. + +Lemma Zeven_pred : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x - 1). +Proof. + exact Zeven.Zeven_pred. +Qed. + +(* This lemma used to be useful since it was mentioned with an unnecessary premise + `x>=0` as Z_modulo_2 in ZArith, but the ZArith version has been fixed. *) + +Definition Z_modulo_2_always : + forall x : Z, {y : Z | x = (2 * y)%Z} + {y : Z | x = (2 * y + 1)%Z} := + Zeven.Z_modulo_2. + +(*###########################################################################*) +(** Properties of Zdiv *) +(*###########################################################################*) + +Lemma Z_div_mod_eq_2 : + forall a b : Z, (0 < b)%Z -> (b * (a / b))%Z = (a - a mod b)%Z. +Proof. + intros. + apply Zplus_minus_eq. + rewrite Zplus_comm. + apply Z_div_mod_eq. + Flip. +Qed. + +Lemma Z_div_le : + forall a b c : Z, (0 < c)%Z -> (b <= a)%Z -> (b / c <= a / c)%Z. +Proof. + intros. + apply Zge_le. + apply Z_div_ge; Flip; assumption. +Qed. + +Lemma Z_div_nonneg : + forall a b : Z, (0 < b)%Z -> (0 <= a)%Z -> (0 <= a / b)%Z. +Proof. + intros. + apply Zge_le. + apply Z_div_ge0; Flip; assumption. +Qed. + +Lemma Z_div_neg : forall a b : Z, (0 < b)%Z -> (a < 0)%Z -> (a / b < 0)%Z. +Proof. + intros. + rewrite (Z_div_mod_eq a b) in H0. + elim (Z_mod_lt a b). + intros H1 _. + apply Znot_ge_lt. + intro. + apply (Zlt_not_le (b * (a / b) + a mod b) 0 H0). + apply Zplus_le_0_compat. + apply Zmult_le_0_compat. + apply Zlt_le_weak; assumption. + Flip. + assumption. + Flip. + Flip. +Qed. + +Hint Resolve Z_div_mod_eq_2 Z_div_le Z_div_nonneg Z_div_neg: zarith. + +(*###########################################################################*) +(** Properties of Zpower *) +(*###########################################################################*) + +Lemma Zpower_1 : forall a : Z, (a ^ 1)%Z = a. +Proof. + intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *; + auto with zarith. +Qed. + +Lemma Zpower_2 : forall a : Z, (a ^ 2)%Z = (a * a)%Z. +Proof. + intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *; + ring. +Qed. + +Hint Resolve Zpower_1 Zpower_2: zarith. diff --git a/test-suite/success/AdvancedCanonicalStructure.v b/test-suite/success/AdvancedCanonicalStructure.v index 97cf316c..d819dc47 100644 --- a/test-suite/success/AdvancedCanonicalStructure.v +++ b/test-suite/success/AdvancedCanonicalStructure.v @@ -47,6 +47,24 @@ Goal forall a1 a2, eqA (plusA a1 zeroA) a2. change (eqB (plusB (phi a1) zeroB) (phi a2)). Admitted. +Variable foo : A -> Type. + +Definition local0 := fun (a1 : A) (a2 : A) (a3 : A) => + (eq_refl : plusA a1 (plusA zeroA a2) = ia _). +Definition local1 := + fun (a1 : A) (a2 : A) (f : A -> A) => + (eq_refl : plusA a1 (plusA zeroA (f a2)) = ia _). + +Definition local2 := + fun (a1 : A) (f : A -> A) => + (eq_refl : (f a1) = ia _). + +Goal forall a1 a2, eqA (plusA a1 zeroA) a2. + intros a1 a2. + refine (eq_img _ _ _). +change (eqB (plusB (phi a1) zeroB) (phi a2)). +Admitted. + End group_morphism. Open Scope type_scope. @@ -129,13 +147,3 @@ Admitted. Check L : abs _ . End type_reification. - - - - - - - - - - diff --git a/test-suite/success/Case11.v b/test-suite/success/Case11.v index fd5d139c..445ffac8 100644 --- a/test-suite/success/Case11.v +++ b/test-suite/success/Case11.v @@ -1,5 +1,5 @@ -(* L'algo d'inférence du prédicat doit gérer le K-rédex dans le type de b *) -(* Problème rapporté par Solange Coupet *) +(* L'algo d'inférence du prédicat doit gérer le K-rédex dans le type de b *) +(* Problème rapporté par Solange Coupet *) Section A. @@ -7,7 +7,7 @@ Variables (Alpha : Set) (Beta : Set). Definition nodep_prod_of_dep (c : sigS (fun a : Alpha => Beta)) : Alpha * Beta := match c with - | existS a b => (a, b) + | existS _ a b => (a, b) end. End A. diff --git a/test-suite/success/Case12.v b/test-suite/success/Case12.v index 729ab824..55e17fac 100644 --- a/test-suite/success/Case12.v +++ b/test-suite/success/Case12.v @@ -68,6 +68,6 @@ Inductive list''' (A:Set) (B:=(A*A)%type) (a:A) : B -> Set := Fixpoint length''' (A:Set) (B:=(A*A)%type) (a:A) (m:B) (l:list''' A a m) {struct l} : nat := match l with - | nil''' => 0 - | cons''' _ m l0 => S (length''' A a m l0) + | nil''' _ _ => 0 + | @cons''' _ _ _ _ m l0 => S (length''' A a m l0) end. diff --git a/test-suite/success/Case16.v b/test-suite/success/Case16.v index 77016bbf..ce9a0ecb 100644 --- a/test-suite/success/Case16.v +++ b/test-suite/success/Case16.v @@ -5,6 +5,6 @@ Check (fun x : {b : bool | if b then True else False} => match x return (let (b, _) := x in if b then True else False) with - | exist true y => y - | exist false z => z + | exist _ true y => y + | exist _ false z => z end). diff --git a/test-suite/success/Case17.v b/test-suite/success/Case17.v index 66af9e0d..861d0466 100644 --- a/test-suite/success/Case17.v +++ b/test-suite/success/Case17.v @@ -19,10 +19,10 @@ Axiom HHH : forall A : Prop, A. Check (match rec l0 (HHH _) with - | inleft (existS (false :: l1) _) => inright _ (HHH _) - | inleft (existS (true :: l1) (exist t1 (conj Hp Hl))) => + | inleft (existS _ (false :: l1) _) => inright _ (HHH _) + | inleft (existS _ (true :: l1) (exist _ t1 (conj Hp Hl))) => inright _ (HHH _) - | inleft (existS _ _) => inright _ (HHH _) + | inleft (existS _ _ _) => inright _ (HHH _) | inright Hnp => inright _ (HHH _) end :{l'' : list bool & @@ -39,10 +39,10 @@ Check {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} + {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}) => match rec l0 (HHH _) with - | inleft (existS (false :: l1) _) => inright _ (HHH _) - | inleft (existS (true :: l1) (exist t1 (conj Hp Hl))) => + | inleft (existS _ (false :: l1) _) => inright _ (HHH _) + | inleft (existS _ (true :: l1) (exist _ t1 (conj Hp Hl))) => inright _ (HHH _) - | inleft (existS _ _) => inright _ (HHH _) + | inleft (existS _ _ _) => inright _ (HHH _) | inright Hnp => inright _ (HHH _) end :{l'' : list bool & diff --git a/test-suite/success/Case20.v b/test-suite/success/Case20.v new file mode 100644 index 00000000..67eebf72 --- /dev/null +++ b/test-suite/success/Case20.v @@ -0,0 +1,35 @@ +(* Example taken from RelationAlgebra *) +(* Was failing from r16205 up to now *) + +Require Import BinNums. + +Section A. + +Context (A:Type) {X: A} (tst:A->Type) (top:forall X, X). + +Inductive v: (positive -> A) -> Type := +| v_L: forall f', v f' +| v_N: forall f', + v (fun n => f' (xO n)) -> + (positive -> tst (f' xH)) -> + v (fun n => f' (xI n)) -> v f'. + +Fixpoint v_add f' (t: v f') n: (positive -> tst (f' n)) -> v f' := + match t in (v o) return ((positive -> (tst (o n))) -> v o) with + | v_L f' => + match n return ((positive -> (tst (f' n))) -> v f') with + | xH => fun x => v_N _ (v_L _) x (v_L _) + | xO n => fun x => v_N _ + (v_add (fun n => f' (xO n)) (v_L _) n x) (fun _ => top _) (v_L _) + | xI n => fun x => v_N _ + (v_L _) (fun _ => top _) (v_add (fun n => f' (xI n)) (v_L _) n x) + end + | v_N f' l y r => + match n with + | xH => fun x => v_N _ l x r + | xO n => fun x => v_N _ (v_add (fun n => f' (xO n)) l n x) y r + | xI n => fun x => v_N _ l y (v_add (fun n => f' (xI n)) r n x) + end + end. + +End A. diff --git a/test-suite/success/Case21.v b/test-suite/success/Case21.v new file mode 100644 index 00000000..db91eb40 --- /dev/null +++ b/test-suite/success/Case21.v @@ -0,0 +1,15 @@ +(* Check insertion of impossible case when there is no branch at all *) + +Inductive eq_true : bool -> Prop := is_eq_true : eq_true true. + +Check fun H:eq_true false => match H with end : False. + +Inductive I : bool -> bool -> Prop := C : I true true. + +Check fun x (H:I x false) => match H with end : False. + +Check fun x (H:I false x) => match H with end : False. + +Inductive I' : bool -> Type := C1 : I' true | C2 : I' true. + +Check fun x : I' false => match x with end : False. diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v new file mode 100644 index 00000000..4eb2dbe9 --- /dev/null +++ b/test-suite/success/Case22.v @@ -0,0 +1,7 @@ +(* Check typing in the presence of let-in in inductive arity *) + +Inductive I : let a := 1 in a=a -> let b := 2 in Type := C : I (eq_refl). +Lemma a : forall x:I eq_refl, match x in I a b c return b = b with C => eq_refl end = eq_refl. +intro. +match goal with |- ?c => let x := eval cbv in c in change x end. +Abort. diff --git a/test-suite/success/Case7.v b/test-suite/success/Case7.v index 6e4b2003..f95598aa 100644 --- a/test-suite/success/Case7.v +++ b/test-suite/success/Case7.v @@ -12,6 +12,6 @@ Parameter Type (fun (A : Set) (l : List A) => match l return (Empty A l \/ ~ Empty A l) with - | Nil => or_introl (~ Empty A (Nil A)) (intro_Empty A) - | Cons a y as b => or_intror (Empty A b) (inv_Empty A a y) + | Nil _ => or_introl (~ Empty A (Nil A)) (intro_Empty A) + | Cons _ a y as b => or_intror (Empty A b) (inv_Empty A a y) end). diff --git a/test-suite/success/Case9.v b/test-suite/success/Case9.v index a8534a0b..e34e5b9b 100644 --- a/test-suite/success/Case9.v +++ b/test-suite/success/Case9.v @@ -36,10 +36,10 @@ Parameter Fixpoint eqlongdec (x y : List nat) {struct x} : eqlong x y \/ ~ eqlong x y := match x, y return (eqlong x y \/ ~ eqlong x y) with - | Nil, Nil => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil - | Nil, Cons a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x) - | Cons a x as L, Nil => or_intror (eqlong L (Nil nat)) (inv_l a x) - | Cons a x as L1, Cons b y as L2 => + | Nil _, Nil _ => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil + | Nil _, Cons _ a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x) + | Cons _ a x as L, Nil _ => or_intror (eqlong L (Nil nat)) (inv_l a x) + | Cons _ a x as L1, Cons _ b y as L2 => match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h) | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h) @@ -49,10 +49,10 @@ Fixpoint eqlongdec (x y : List nat) {struct x} : Type match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with - | Nil, Nil => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil - | Nil, Cons a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x) - | Cons a x as L, Nil => or_intror (eqlong L (Nil nat)) (inv_l a x) - | Cons a x as L1, Cons b y as L2 => + | Nil _, Nil _ => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil + | Nil _, Cons _ a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x) + | Cons _ a x as L, Nil _ => or_intror (eqlong L (Nil nat)) (inv_l a x) + | Cons _ a x as L1, Cons _ b y as L2 => match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h) | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h) diff --git a/test-suite/success/CaseInClause.v b/test-suite/success/CaseInClause.v new file mode 100644 index 00000000..3679eead --- /dev/null +++ b/test-suite/success/CaseInClause.v @@ -0,0 +1,22 @@ +(* in clause pattern *) +Require Vector. +Check (fun n (x: Vector.t True (S n)) => + match x in Vector.t _ (S m) return True with + |Vector.cons _ h _ _ => h + end). + +(* Notation *) +Import Vector.VectorNotations. +Notation "A \dots n" := (Vector.t A n) (at level 200). +Check (fun m (x: Vector.t nat m) => + match x in _ \dots k return Vector.t nat (S k) with + | Vector.nil _ => 0 :: [] + | Vector.cons _ h _ t => h :: h :: t + end). + +(* N should be a variable and not the inductiveRef *) +Require Import NArith. +Theorem foo : forall (n m : nat) (pf : n = m), + match pf in _ = N with + | eq_refl => unit + end. diff --git a/test-suite/success/Cases-bug1834.v b/test-suite/success/Cases-bug1834.v index 543ca0c9..cf102486 100644 --- a/test-suite/success/Cases-bug1834.v +++ b/test-suite/success/Cases-bug1834.v @@ -7,7 +7,7 @@ Definition T := sig P. Parameter Q : T -> Prop. Definition U := sig Q. Parameter a : U. -Check (match a with exist (exist tt e2) e3 => e3=e3 end). +Check (match a with exist _ (exist _ tt e2) e3 => e3=e3 end). (* There is still a form submitted by Pierre Corbineau (#1834) which fails *) diff --git a/test-suite/success/Cases-bug3758.v b/test-suite/success/Cases-bug3758.v new file mode 100644 index 00000000..e48f4523 --- /dev/null +++ b/test-suite/success/Cases-bug3758.v @@ -0,0 +1,17 @@ +(* There used to be an evar leak in the to_nat example *) + +Require Import Coq.Lists.List. +Import ListNotations. + +Fixpoint Idx {A:Type} (l:list A) : Type := + match l with + | [] => False + | _::l => True + Idx l + end. + +Fixpoint to_nat {A:Type} (l:list A) (i:Idx l) : nat := + match l,i with + | [] , i => match i with end + | _::_, inl _ => 0 + | _::l, inr i => S (to_nat l i) + end. diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index c9a3c08e..e4266350 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -2,21 +2,21 @@ (* Pattern-matching when non inductive terms occur *) (* Dependent form of annotation *) -Type match 0 as n, eq return nat with +Type match 0 as n, @eq return nat with | O, x => 0 | S x, y => x end. -Type match 0, eq, 0 return nat with +Type match 0, 0, @eq return nat with | O, x, y => 0 | S x, y, z => x end. -Type match 0, eq, 0 return _ with +Type match 0, @eq, 0 return _ with | O, x, y => 0 | S x, y, z => x end. (* Non dependent form of annotation *) -Type match 0, eq return nat with +Type match 0, @eq return nat with | O, x => 0 | S x, y => x end. @@ -309,43 +309,43 @@ Type Type (fun l : List nat => match l return (List nat) with - | Nil => Nil nat - | Cons a l => l + | Nil _ => Nil nat + | Cons _ a l => l end). Type (fun l : List nat => match l with - | Nil => Nil nat - | Cons a l => l + | Nil _ => Nil nat + | Cons _ a l => l end). Type match Nil nat return nat with - | Nil => 0 - | Cons a l => S a + | Nil _ => 0 + | Cons _ a l => S a end. Type match Nil nat with - | Nil => 0 - | Cons a l => S a + | Nil _ => 0 + | Cons _ a l => S a end. Type match Nil nat return (List nat) with - | Cons a l => l + | Cons _ a l => l | x => x end. Type match Nil nat with - | Cons a l => l + | Cons _ a l => l | x => x end. Type match Nil nat return (List nat) with - | Nil => Nil nat - | Cons a l => l + | Nil _ => Nil nat + | Cons _ a l => l end. Type match Nil nat with - | Nil => Nil nat - | Cons a l => l + | Nil _ => Nil nat + | Cons _ a l => l end. @@ -353,8 +353,8 @@ Type match 0 return nat with | O => 0 | S x => match Nil nat return nat with - | Nil => x - | Cons a l => x + a + | Nil _ => x + | Cons _ a l => x + a end end. @@ -362,8 +362,8 @@ Type match 0 with | O => 0 | S x => match Nil nat with - | Nil => x - | Cons a l => x + a + | Nil _ => x + | Cons _ a l => x + a end end. @@ -372,8 +372,8 @@ Type match y with | O => 0 | S x => match Nil nat with - | Nil => x - | Cons a l => x + a + | Nil _ => x + | Cons _ a l => x + a end end). @@ -381,8 +381,8 @@ Type Type match 0, Nil nat return nat with | O, x => 0 - | S x, Nil => x - | S x, Cons a l => x + a + | S x, Nil _ => x + | S x, Cons _ a l => x + a end. @@ -597,71 +597,60 @@ Type Type (fun (A : Set) (n : nat) (l : Listn A n) => match l return nat with - | Niln => 0 - | Consn n a Niln => 0 - | Consn n a (Consn m b l) => n + m + | Niln _ => 0 + | Consn _ n a (Niln _) => 0 + | Consn _ n a (Consn _ m b l) => n + m end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with - | Niln => 0 - | Consn n a Niln => 0 - | Consn n a (Consn m b l) => n + m + | Niln _ => 0 + | Consn _ n a (Niln _) => 0 + | Consn _ n a (Consn _ m b l) => n + m end). -(* This example was deactivated in Cristina's code - Type (fun (A:Set) (n:nat) (l:Listn A n) => match l return Listn A O with - | Niln as b => b - | Consn n a (Niln as b) => (Niln A) - | Consn n a (Consn m b l) => (Niln A) + | Niln _ as b => b + | Consn _ n a (Niln _ as b) => (Niln A) + | Consn _ n a (Consn _ m b l) => (Niln A) end). -*) - -(* This one is (still) failing: too weak unification +(* Type (fun (A:Set) (n:nat) (l:Listn A n) => match l with - | Niln as b => b - | Consn n a (Niln as b) => (Niln A) - | Consn n a (Consn m b l) => (Niln A) + | Niln _ as b => b + | Consn _ n a (Niln _ as b) => (Niln A) + | Consn _ n a (Consn _ m b l) => (Niln A) end). *) -(* This one is failing: alias L not chosen of the right type - Type (fun (A:Set) (n:nat) (l:Listn A n) => match l return Listn A (S 0) with - | Niln as b => Consn A O O b - | Consn n a Niln as L => L - | Consn n a _ => Consn A O O (Niln A) + | Niln _ as b => Consn A O O b + | Consn _ n a (Niln _) as L => L + | Consn _ n a _ => Consn A O O (Niln A) end). -*) - -(******** This example (still) failed Type (fun (A:Set) (n:nat) (l:Listn A n) => match l return Listn A (S 0) with - | Niln as b => Consn A O O b - | Consn n a Niln as L => L - | Consn n a _ => Consn A O O (Niln A) + | Niln _ as b => Consn A O O b + | Consn _ n a (Niln _) as L => L + | Consn _ n a _ => Consn A O O (Niln A) end). -**********) - (* To test treatment of as-patterns in depth *) Type (fun (A : Set) (l : List A) => match l with - | Nil as b => Nil A - | Cons a Nil as L => L - | Cons a (Cons b m) as L => L + | Nil _ as b => Nil A + | Cons _ a (Nil _) as L => L + | Cons _ a (Cons _ b m) as L => L end). @@ -704,40 +693,40 @@ Type Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with - | Niln as b => l + | Niln _ as b => l | _ => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l return (Listn A n) with - | Niln => l - | Consn n a Niln => l - | Consn n a (Consn m b c) => l + | Niln _ => l + | Consn _ n a (Niln _) => l + | Consn _ n a (Consn _ m b c) => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with - | Niln => l - | Consn n a Niln => l - | Consn n a (Consn m b c) => l + | Niln _ => l + | Consn _ n a (Niln _) => l + | Consn _ n a (Consn _ m b c) => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l return (Listn A n) with - | Niln as b => l - | Consn n a (Niln as b) => l - | Consn n a (Consn m b _) => l + | Niln _ as b => l + | Consn _ n a (Niln _ as b) => l + | Consn _ n a (Consn _ m b _) => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with - | Niln as b => l - | Consn n a (Niln as b) => l - | Consn n a (Consn m b _) => l + | Niln _ as b => l + | Consn _ n a (Niln _ as b) => l + | Consn _ n a (Consn _ m b _) => l end). @@ -770,40 +759,40 @@ Type match LeO 0 with Type (fun (n : nat) (l : Listn nat n) => match l return nat with - | Niln => 0 - | Consn n a l => 0 + | Niln _ => 0 + | Consn _ n a l => 0 end). Type (fun (n : nat) (l : Listn nat n) => match l with - | Niln => 0 - | Consn n a l => 0 + | Niln _ => 0 + | Consn _ n a l => 0 end). Type match Niln nat with - | Niln => 0 - | Consn n a l => 0 + | Niln _ => 0 + | Consn _ n a l => 0 end. Type match LE_n 0 return nat with - | LE_n => 0 - | LE_S m h => 0 + | LE_n _ => 0 + | LE_S _ m h => 0 end. Type match LE_n 0 with - | LE_n => 0 - | LE_S m h => 0 + | LE_n _ => 0 + | LE_S _ m h => 0 end. Type match LE_n 0 with - | LE_n => 0 - | LE_S m h => 0 + | LE_n _ => 0 + | LE_S _ m h => 0 end. @@ -825,16 +814,17 @@ Type Type match Niln nat return nat with - | Niln => 0 - | Consn n a Niln => n - | Consn n a (Consn m b l) => n + m + | Niln _ => 0 + | Consn _ n a (Niln _ +) => n + | Consn _ n a (Consn _ m b l) => n + m end. Type match Niln nat with - | Niln => 0 - | Consn n a Niln => n - | Consn n a (Consn m b l) => n + m + | Niln _ => 0 + | Consn _ n a (Niln _) => n + | Consn _ n a (Consn _ m b l) => n + m end. @@ -1027,17 +1017,17 @@ Type Type match LE_n 0 return nat with - | LE_n => 0 - | LE_S m LE_n => 0 + m - | LE_S m (LE_S y h) => 0 + m + | LE_n _ => 0 + | LE_S _ m (LE_n _) => 0 + m + | LE_S _ m (LE_S _ y h) => 0 + m end. Type match LE_n 0 with - | LE_n => 0 - | LE_S m LE_n => 0 + m - | LE_S m (LE_S y h) => 0 + m + | LE_n _ => 0 + | LE_S _ m (LE_n _) => 0 + m + | LE_S _ m (LE_S _ y h) => 0 + m end. @@ -1077,25 +1067,25 @@ Type Type (fun (A : Set) (n : nat) (l : Listn A n) => match l return (nat -> nat) with - | Niln => fun _ : nat => 0 - | Consn n a Niln => fun _ : nat => n - | Consn n a (Consn m b l) => fun _ : nat => n + m + | Niln _ => fun _ : nat => 0 + | Consn _ n a (Niln _) => fun _ : nat => n + | Consn _ n a (Consn _ m b l) => fun _ : nat => n + m end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with - | Niln => fun _ : nat => 0 - | Consn n a Niln => fun _ : nat => n - | Consn n a (Consn m b l) => fun _ : nat => n + m + | Niln _ => fun _ : nat => 0 + | Consn _ n a (Niln _) => fun _ : nat => n + | Consn _ n a (Consn _ m b l) => fun _ : nat => n + m end). (* Also tests for multiple _ patterns *) Type (fun (A : Set) (n : nat) (l : Listn A n) => match l in (Listn _ n) return (Listn A n) with - | Niln as b => b - | Consn _ _ _ as b => b + | Niln _ as b => b + | Consn _ _ _ _ as b => b end). (** This one was said to raised once an "Horrible error message!" *) @@ -1103,8 +1093,8 @@ Type Type (fun (A:Set) (n:nat) (l:Listn A n) => match l with - | Niln as b => b - | Consn _ _ _ as b => b + | Niln _ as b => b + | Consn _ _ _ _ as b => b end). Type @@ -1123,26 +1113,26 @@ Type Type (fun (n m : nat) (h : LE n m) => match h return (nat -> nat) with - | LE_n => fun _ : nat => n - | LE_S m LE_n => fun _ : nat => n + m - | LE_S m (LE_S y h) => fun _ : nat => m + y + | LE_n _ => fun _ : nat => n + | LE_S _ m (LE_n _) => fun _ : nat => n + m + | LE_S _ m (LE_S _ y h) => fun _ : nat => m + y end). Type (fun (n m : nat) (h : LE n m) => match h with - | LE_n => fun _ : nat => n - | LE_S m LE_n => fun _ : nat => n + m - | LE_S m (LE_S y h) => fun _ : nat => m + y + | LE_n _ => fun _ : nat => n + | LE_S _ m (LE_n _) => fun _ : nat => n + m + | LE_S _ m (LE_S _ y h) => fun _ : nat => m + y end). Type (fun (n m : nat) (h : LE n m) => match h return nat with - | LE_n => n - | LE_S m LE_n => n + m - | LE_S m (LE_S y LE_n) => n + m + y - | LE_S m (LE_S y (LE_S y' h)) => n + m + (y + y') + | LE_n _ => n + | LE_S _ m (LE_n _) => n + m + | LE_S _ m (LE_S _ y (LE_n _)) => n + m + y + | LE_S _ m (LE_S _ y (LE_S _ y' h)) => n + m + (y + y') end). @@ -1150,28 +1140,28 @@ Type Type (fun (n m : nat) (h : LE n m) => match h with - | LE_n => n - | LE_S m LE_n => n + m - | LE_S m (LE_S y LE_n) => n + m + y - | LE_S m (LE_S y (LE_S y' h)) => n + m + (y + y') + | LE_n _ => n + | LE_S _ m (LE_n _) => n + m + | LE_S _ m (LE_S _ y (LE_n _)) => n + m + y + | LE_S _ m (LE_S _ y (LE_S _ y' h)) => n + m + (y + y') end). Type (fun (n m : nat) (h : LE n m) => match h return nat with - | LE_n => n - | LE_S m LE_n => n + m - | LE_S m (LE_S y h) => n + m + y + | LE_n _ => n + | LE_S _ m (LE_n _) => n + m + | LE_S _ m (LE_S _ y h) => n + m + y end). Type (fun (n m : nat) (h : LE n m) => match h with - | LE_n => n - | LE_S m LE_n => n + m - | LE_S m (LE_S y h) => n + m + y + | LE_n _ => n + | LE_S _ m (LE_n _) => n + m + | LE_S _ m (LE_S _ y h) => n + m + y end). Type @@ -1231,14 +1221,14 @@ Parameter B : Set. Type (fun (P : nat -> B -> Prop) (x : SStream B P) => match x return B with - | scons _ a _ _ => a + | scons _ _ a _ _ => a end). Type (fun (P : nat -> B -> Prop) (x : SStream B P) => match x with - | scons _ a _ _ => a + | scons _ _ a _ _ => a end). Type match (0, 0) return (nat * nat) with @@ -1267,14 +1257,14 @@ Parameter concat : forall A : Set, List A -> List A -> List A. Type match Nil nat, Nil nat return (List nat) with - | Nil as b, x => concat nat b x - | Cons _ _ as d, Nil as c => concat nat d c + | Nil _ as b, x => concat nat b x + | Cons _ _ _ as d, Nil _ as c => concat nat d c | _, _ => Nil nat end. Type match Nil nat, Nil nat with - | Nil as b, x => concat nat b x - | Cons _ _ as d, Nil as c => concat nat d c + | Nil _ as b, x => concat nat b x + | Cons _ _ _ as d, Nil _ as c => concat nat d c | _, _ => Nil nat end. @@ -1415,7 +1405,7 @@ Parameter p : eq_prf. Type match p with - | ex_intro c eqc => + | ex_intro _ c eqc => match eq_nat_dec c n with | right _ => refl_equal n | left y => (* c=n*) refl_equal n @@ -1438,7 +1428,7 @@ Type (fun N : nat => match N_cla N with | inright H => match exist_U2 N H with - | exist a b => a + | exist _ a b => a end | _ => 0 end). @@ -1636,8 +1626,8 @@ Parameter Type match Nil nat as l return (Empty nat l \/ ~ Empty nat l) with - | Nil => or_introl (~ Empty nat (Nil nat)) (intro_Empty nat) - | Cons a y => or_intror (Empty nat (Cons nat a y)) (inv_Empty nat a y) + | Nil _ => or_introl (~ Empty nat (Nil nat)) (intro_Empty nat) + | Cons _ a y => or_intror (Empty nat (Cons nat a y)) (inv_Empty nat a y) end. @@ -1687,20 +1677,20 @@ Parameter Type match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with - | Nil, Nil => V1 - | Nil, Cons a x => V2 a x - | Cons a x, Nil => V3 a x - | Cons a x, Cons b y => V4 a x b y + | Nil _, Nil _ => V1 + | Nil _, Cons _ a x => V2 a x + | Cons _ a x, Nil _ => V3 a x + | Cons _ a x, Cons _ b y => V4 a x b y end. Type (fun x y : List nat => match x, y return (eqlong x y \/ ~ eqlong x y) with - | Nil, Nil => V1 - | Nil, Cons a x => V2 a x - | Cons a x, Nil => V3 a x - | Cons a x, Cons b y => V4 a x b y + | Nil _, Nil _ => V1 + | Nil _, Cons _ a x => V2 a x + | Cons _ a x, Nil _ => V3 a x + | Cons _ a x, Cons _ b y => V4 a x b y end). diff --git a/test-suite/success/CasesDep.v b/test-suite/success/CasesDep.v index bfead53c..8d9edbd6 100644 --- a/test-suite/success/CasesDep.v +++ b/test-suite/success/CasesDep.v @@ -4,8 +4,8 @@ Check (fun (P : nat -> Prop) Q (A : P 0 -> Q) (B : forall n : nat, P (S n) -> Q) x => match x return Q with - | exist O H => A H - | exist (S n) H => B n H + | exist _ O H => A H + | exist _ (S n) H => B n H end). (* Check dependencies in anonymous arguments (from FTA/listn.v) *) @@ -21,30 +21,30 @@ Variable c : C. Fixpoint foldrn (n : nat) (bs : listn B n) {struct bs} : C := match bs with - | niln => c - | consn b _ tl => g b (foldrn _ tl) + | niln _ => c + | consn _ b _ tl => g b (foldrn _ tl) end. End Folding. (** Testing post-processing of nested dependencies *) Check fun x:{x|x=0}*nat+nat => match x with - | inl ((exist 0 eq_refl),0) => None + | inl ((exist _ 0 eq_refl),0) => None | _ => Some 0 end. Check fun x:{_:{x|x=0}|True}+nat => match x with - | inl (exist (exist 0 eq_refl) I) => None + | inl (exist _ (exist _ 0 eq_refl) I) => None | _ => Some 0 end. Check fun x:{_:{x|x=0}|True}+nat => match x with - | inl (exist (exist 0 eq_refl) I) => None + | inl (exist _ (exist _ 0 eq_refl) I) => None | _ => Some 0 end. Check fun x:{_:{x|x=0}|True}+nat => match x return option nat with - | inl (exist (exist 0 eq_refl) I) => None + | inl (exist _ (exist _ 0 eq_refl) I) => None | _ => Some 0 end. @@ -52,11 +52,11 @@ Check fun x:{_:{x|x=0}|True}+nat => match x return option nat with (* due to a bug in dependencies postprocessing (revealed by CoLoR) *) Check fun x:{x:nat*nat|fst x = 0 & True} => match x return option nat with - | exist2 (x,y) eq_refl I => None + | exist2 _ _ (x,y) eq_refl I => None end. Check fun x:{_:{x:nat*nat|fst x = 0 & True}|True}+nat => match x return option nat with - | inl (exist (exist2 (x,y) eq_refl I) I) => None + | inl (exist _ (exist2 _ _ (x,y) eq_refl I) I) => None | _ => Some 0 end. @@ -521,8 +521,8 @@ end. Fixpoint app {A} {n m} (v : listn A n) (w : listn A m) : listn A (n + m) := match v with - | niln => w - | consn a n' v' => consn _ a _ (app v' w) + | niln _ => w + | consn _ a n' v' => consn _ a _ (app v' w) end. (* Testing regression of bug 2106 *) @@ -547,7 +547,7 @@ n'. Definition test (s:step E E) := match s with - | Step nil _ (cons E nil) _ Plus l l' => true + | @Step nil _ (cons E nil) _ Plus l l' => true | _ => false end. diff --git a/test-suite/success/Check.v b/test-suite/success/Check.v index 49c54916..87c38cfa 100644 --- a/test-suite/success/Check.v +++ b/test-suite/success/Check.v @@ -1,11 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* C -> C) (c : C). Fixpoint foldrn n bs := match bs with - | Vnil => c - | Vcons b _ tl => g b (foldrn _ tl) + | Vnil _ => c + | Vcons _ b _ tl => g b (foldrn _ tl) end. End folding. diff --git a/test-suite/success/Funind.v b/test-suite/success/Funind.v index ccce3bbe..3bf97c13 100644 --- a/test-suite/success/Funind.v +++ b/test-suite/success/Funind.v @@ -23,6 +23,7 @@ Function ftest (n m : nat) : nat := end | S p => 0 end. +(* MS: FIXME: apparently can't define R_ftest_complete. Rest of the file goes through. *) Lemma test1 : forall n m : nat, ftest n m <= 2. intros n m. @@ -150,7 +151,7 @@ Function nat_equal_bool (n m : nat) {struct n} : bool := Require Export Div2. - +Require Import Nat. Functional Scheme div2_ind := Induction for div2 Sort Prop. Lemma div2_inf : forall n : nat, div2 n <= n. intros n. @@ -233,11 +234,11 @@ Qed. Inductive istrue : bool -> Prop := istrue0 : istrue true. -Functional Scheme plus_ind := Induction for plus Sort Prop. +Functional Scheme add_ind := Induction for add Sort Prop. Lemma inf_x_plusxy' : forall x y : nat, x <= x + y. intros n m. - functional induction plus n m; intros. + functional induction add n m; intros. auto with arith. auto with arith. Qed. diff --git a/test-suite/success/ImplicitArguments.v b/test-suite/success/ImplicitArguments.v index 84ec298d..f702aa62 100644 --- a/test-suite/success/ImplicitArguments.v +++ b/test-suite/success/ImplicitArguments.v @@ -9,11 +9,15 @@ Require Import Coq.Program.Program. Program Definition head {A : Type} {n : nat} (v : vector A (S n)) : vector A n := match v with | vnil => ! - | vcons a n' v' => v' + | vcons a v' => v' end. Fixpoint app {A : Type} {n m : nat} (v : vector A n) (w : vector A m) : vector A (n + m) := match v in vector _ n return vector A (n + m) with | vnil => w - | vcons a n' v' => vcons a (app v' w) + | vcons a v' => vcons a (app v' w) end. + +(* Test sharing information between different hypotheses *) + +Parameters (a:_) (b:a=0). diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v index da5dd5e4..3d425754 100644 --- a/test-suite/success/Inductive.v +++ b/test-suite/success/Inductive.v @@ -17,7 +17,7 @@ Check fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) => let B := A in fun (a : A) (e : eq1 A a) => - match e in (eq1 A0 B0 a0) return (P A0 a0) with + match e in (@eq1 A0 B0 a0) return (P A0 a0) with | refl1 => f end. @@ -37,8 +37,8 @@ Check fun (x y : E -> F) (P : forall c : C, A C D x y c -> Type) (f : forall z : C, P z (I C D x y z)) (y0 : C) (a : A C D x y y0) => - match a as a0 in (A _ _ _ _ _ _ y1) return (P y1 a0) with - | I x0 => f x0 + match a as a0 in (A _ _ _ _ y1) return (P y1 a0) with + | I _ _ _ _ x0 => f x0 end). Record B (C D : Set) (E:=C) (F:=D) (x y : E -> F) : Set := {p : C; q : E}. @@ -51,7 +51,7 @@ Check (f : forall p0 q0 : C, P (Build_B C D x y p0 q0)) (b : B C D x y) => match b as b0 return (P b0) with - | Build_B x0 x1 => f x0 x1 + | Build_B _ _ _ _ x0 x1 => f x0 x1 end). (* Check inductive types with local definitions (constructors) *) @@ -107,3 +107,17 @@ Set Implicit Arguments. Inductive I A : A->Prop := C a : (forall A, A) -> I a. *) + +(* Test recursively non-uniform parameters (was formerly in params_ind.v) *) + +Inductive list (A : Set) : Set := + | nil : list A + | cons : A -> list (A -> A) -> list A. + +(* Check inference of evars in arity using information from constructors *) + +Inductive foo1 : forall p, Prop := cc1 : foo1 0. + +(* Check cross inference of evars from constructors *) + +Inductive foo2 : forall p, Prop := cc2 : forall q, foo2 q | cc3 : foo2 0. diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v index c5cd7380..6a488244 100644 --- a/test-suite/success/Injection.v +++ b/test-suite/success/Injection.v @@ -39,7 +39,7 @@ Qed. (* Test injection as *) Lemma l5 : forall x y z t : nat, (x,y) = (z,t) -> x=z. -intros; injection H as Hyt Hxz. +intros; injection H as Hxz Hyt. exact Hxz. Qed. @@ -66,6 +66,56 @@ einjection (H O). instantiate (1:=O). Abort. +(* Test the injection intropattern *) + +Goal forall (a b:nat) l l', cons a l = cons b l' -> a=b. +intros * [= H1 H2]. +exact H1. +Qed. + +(* Test injection using K, knowing that an equality is decidable *) +(* Basic case, using sigT *) + +Scheme Equality for nat. +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + existT P n H1 = existT P n H2 -> H1 = H2. +intros. +injection H. +intro H0. exact H0. +Abort. + +(* Test injection using K, knowing that an equality is decidable *) +(* Basic case, using sigT, with "as" clause *) + +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + existT P n H1 = existT P n H2 -> H1 = H2. +intros. +injection H as H. +exact H. +Abort. + +(* Test injection using K, knowing that an equality is decidable *) +(* Dependent case not directly exposing sigT *) + +Inductive my_sig (A : Type) (P : A -> Type) : Type := + my_exist : forall x : A, P x -> my_sig A P. + +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + my_exist _ _ n H1 = my_exist _ _ n H2 -> H1 = H2. +intros. +injection H as H. +exact H. +Abort. + +(* Test injection using K, knowing that an equality is decidable *) +(* Dependent case not directly exposing sigT deeply nested *) + +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + (my_exist _ _ n H1,0) = (my_exist _ _ n H2,0) -> H1 = H2. +intros * [= H]. +exact H. +Abort. + (* Injection does not projects at positions in Prop... allow it? Inductive t (A:Prop) : Set := c : A -> t A. diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v index b068f729..850f0943 100644 --- a/test-suite/success/Inversion.v +++ b/test-suite/success/Inversion.v @@ -136,3 +136,56 @@ Goal True -> True. intro. Fail inversion H using False. Fail inversion foo using True_ind. + +(* Was failing at some time between 7 and 10 September 2014 *) +(* even though, it is not clear that the resulting context is interesting *) + +Parameter P:nat*nat->Prop. +Inductive IND : nat * nat -> { x : nat * nat | P x } * nat -> Prop := +CONSTR a b (H:P (a,b)) c : IND (a,b) (exist _ (a,b) H, c). + +Goal forall x y z t u (H':P (z,t)), IND (x,y) (exist _ (z,t) H', u) -> x = z. +intros * Hyp. +inversion Hyp. + (* By the way, why is "H" removed even in non-clear mode ? *) +reflexivity. +Qed. + +Goal forall x y z t u (H':P (z,t)), IND (x,y) (exist _ (z,t) H', u) -> x = z. +intros * Hyp. +inversion Hyp as (a,b,H,c,(H1_1,H1_2),(H2_1,H2_2,H2_3)). +reflexivity. +Qed. + +(* Up to September 2014, Mapp below was called MApp0 because of a bug + in intro_replacing (short version of bug 2164.v) + (example taken from CoLoR) *) + +Parameter Term : Type. +Parameter isApp : Term -> Prop. +Parameter appBodyL : forall M, isApp M -> Prop. +Parameter lower : forall M Mapp, appBodyL M Mapp -> Term. + +Inductive BetaStep : Term -> Term -> Prop := + Beta M Mapp Mabs : BetaStep M (lower M Mapp Mabs). + +Goal forall M N, BetaStep M N -> True. +intros M N H. +inversion H as (P,Mapp,Mabs,H0,H1). +clear Mapp Mabs H0 H1. +exact Logic.I. +Qed. + +(* Up to September 2014, H0 below was renamed called H1 because of a collision + with the automaticallly generated names for equations. + (example taken from CoLoR) *) + +Inductive term := Var | Fun : term -> term -> term. +Inductive lt : term -> term -> Prop := + mpo f g ss ts : lt Var (Fun f ts) -> lt (Fun f ss) (Fun g ts). + +Goal forall f g ss ts, lt (Fun f ss) (Fun g ts) -> lt Var (Fun f ts). +intros. +inversion H as (f',g',ss',ts',H0). +exact H0. +Qed. diff --git a/test-suite/success/LegacyField.v b/test-suite/success/LegacyField.v deleted file mode 100644 index 9b2a2c6a..00000000 --- a/test-suite/success/LegacyField.v +++ /dev/null @@ -1,76 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* R) (x0 x1 : R), -((f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)))%R = -((f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)))%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 3 *) -Goal forall a b : R, (1 / (a * b) * (1 / 1 / b))%R = (1 / a)%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 4 *) -Goal -forall a b : R, a <> 0%R -> b <> 0%R -> (1 / (a * b) / 1 / b)%R = (1 / a)%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 5 *) -Goal forall a : R, 1%R = (1 * (1 / a) * a)%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 6 *) -Goal forall a b : R, b = (b * / a * a)%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 7 *) -Goal forall a b : R, b = (b * (1 / a) * a)%R. -Proof. - intros. - legacy field. -Abort. - -(* Example 8 *) -Goal -forall x y : R, -(x * (1 / x + x / (x + y)))%R = -(- (1 / y) * y * (- (x * (x / (x + y))) - 1))%R. -Proof. - intros. - legacy field. -Abort. diff --git a/test-suite/success/LetPat.v b/test-suite/success/LetPat.v index 4c790680..0e557aee 100644 --- a/test-suite/success/LetPat.v +++ b/test-suite/success/LetPat.v @@ -9,22 +9,22 @@ Print l3. Record someT (A : Type) := mkT { a : nat; b: A }. -Definition l4 A (t : someT A) : nat := let 'mkT x y := t in x. +Definition l4 A (t : someT A) : nat := let 'mkT _ x y := t in x. Print l4. Print sigT. Definition l5 A (B : A -> Type) (t : sigT B) : B (projT1 t) := - let 'existT x y := t return B (projT1 t) in y. + let 'existT _ x y := t return B (projT1 t) in y. Definition l6 A (B : A -> Type) (t : sigT B) : B (projT1 t) := - let 'existT x y as t' := t return B (projT1 t') in y. + let 'existT _ x y as t' := t return B (projT1 t') in y. Definition l7 A (B : A -> Type) (t : sigT B) : B (projT1 t) := - let 'existT x y as t' in sigT _ := t return B (projT1 t') in y. + let 'existT _ x y as t' in sigT _ := t return B (projT1 t') in y. Definition l8 A (B : A -> Type) (t : sigT B) : B (projT1 t) := match t with - existT x y => y + existT _ x y => y end. (** An example from algebra, using let' and inference of return clauses diff --git a/test-suite/success/MatchFail.v b/test-suite/success/MatchFail.v index c2d87a44..7069bba4 100644 --- a/test-suite/success/MatchFail.v +++ b/test-suite/success/MatchFail.v @@ -4,7 +4,7 @@ Require Export ZArithRing. (* Cette tactique a pour objectif de remplacer toute instance de (POS (xI e)) ou de (POS (xO e)) par 2*(POS e)+1 ou 2*(POS e), pour rendre les expressions plus - à même d'être utilisées par Ring, lorsque ces expressions contiennent + à même d'être utilisées par Ring, lorsque ces expressions contiennent des variables de type positive. *) Ltac compute_POS := match goal with diff --git a/test-suite/success/NumberScopes.v b/test-suite/success/NumberScopes.v new file mode 100644 index 00000000..6d787210 --- /dev/null +++ b/test-suite/success/NumberScopes.v @@ -0,0 +1,62 @@ + +(* We check that various definitions or lemmas have the correct + argument scopes, especially the ones created via functor application. *) + +Close Scope nat_scope. + +Require Import PArith. +Check (Pos.add 1 2). +Check (Pos.add_comm 1 2). +Check (Pos.min_comm 1 2). +Definition f_pos (x:positive) := x. +Definition f_pos' (x:Pos.t) := x. +Check (f_pos 1). +Check (f_pos' 1). + +Require Import ZArith. +Check (Z.add 1 2). +Check (Z.add_comm 1 2). +Check (Z.min_comm 1 2). +Definition f_Z (x:Z) := x. +Definition f_Z' (x:Z.t) := x. +Check (f_Z 1). +Check (f_Z' 1). + +Require Import NArith. +Check (N.add 1 2). +Check (N.add_comm 1 2). +Check (N.min_comm 1 2). +Definition f_N (x:N) := x. +Definition f_N' (x:N.t) := x. +Check (f_N 1). +Check (f_N' 1). + +Require Import Arith. +Check (Nat.add 1 2). +Check (Nat.add_comm 1 2). +Check (Nat.min_comm 1 2). +Definition f_nat (x:nat) := x. +Definition f_nat' (x:Nat.t) := x. +Check (f_nat 1). +Check (f_nat' 1). + +Require Import BigN. +Check (BigN.add 1 2). +Check (BigN.add_comm 1 2). +Check (BigN.min_comm 1 2). +Definition f_bigN (x:bigN) := x. +Check (f_bigN 1). + +Require Import BigZ. +Check (BigZ.add 1 2). +Check (BigZ.add_comm 1 2). +Check (BigZ.min_comm 1 2). +Definition f_bigZ (x:bigZ) := x. +Check (f_bigZ 1). + +Require Import BigQ. +Check (BigQ.add 1 2). +Check (BigQ.add_comm 1 2). +Check (BigQ.min_comm 1 2). +Definition f_bigQ (x:bigQ) := x. +Check (f_bigQ 1). \ No newline at end of file diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v index 3b7f0d84..681c4716 100644 --- a/test-suite/success/ProgramWf.v +++ b/test-suite/success/ProgramWf.v @@ -100,6 +100,6 @@ Next Obligation. simpl in *; intros. apply H. simpl. omega. Qed. -Program Fixpoint check_n' (n : nat) (m : nat | m = n) (p : nat) (q : nat | q = p) +Program Fixpoint check_n' (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p}) {measure (p - n) p} : nat := - _. + _. \ No newline at end of file diff --git a/test-suite/success/Projection.v b/test-suite/success/Projection.v index d8faa88a..3ffd41ea 100644 --- a/test-suite/success/Projection.v +++ b/test-suite/success/Projection.v @@ -1,3 +1,9 @@ +Record foo (A : Type) := { B :> Type }. + +Lemma bar (f : foo nat) (x : f) : x = x. + destruct f. simpl B. simpl B in x. +Abort. + Structure S : Type := {Dom : Type; Op : Dom -> Dom -> Dom}. Check (fun s : S => Dom s). diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v index 459645f6..11fbf24d 100644 --- a/test-suite/success/RecTutorial.v +++ b/test-suite/success/RecTutorial.v @@ -301,8 +301,8 @@ Section Le_case_analysis. (HS : forall m, n <= m -> Q (S m)). Check ( match H in (_ <= q) return (Q q) with - | le_n => H0 - | le_S m Hm => HS m Hm + | le_n _ => H0 + | le_S _ m Hm => HS m Hm end ). @@ -320,8 +320,8 @@ Qed. Definition Vtail_total (A : Set) (n : nat) (v : Vector.t A n) : Vector.t A (pred n):= match v in (Vector.t _ n0) return (Vector.t A (pred n0)) with -| Vector.nil => Vector.nil A -| Vector.cons _ n0 v0 => v0 +| Vector.nil _ => Vector.nil A +| Vector.cons _ _ n0 v0 => v0 end. Definition Vtail' (A:Set)(n:nat)(v:Vector.t A n) : Vector.t A (pred n). @@ -520,8 +520,7 @@ Inductive typ : Type := Definition typ_inject: typ. split. -exact typ. -Fail Defined. +Fail exact typ. (* Error: Universe Inconsistency. *) @@ -1060,8 +1059,8 @@ Fixpoint vector_nth (A:Set)(n:nat)(p:nat)(v:Vector.t A p){struct v} : option A := match n,v with _ , Vector.nil => None - | 0 , Vector.cons b _ _ => Some b - | S n', Vector.cons _ p' v' => vector_nth A n' p' v' + | 0 , Vector.cons b _ => Some b + | S n', Vector.cons _ v' => vector_nth A n' _ v' end. Implicit Arguments vector_nth [A p]. diff --git a/test-suite/success/Scopes.v b/test-suite/success/Scopes.v index a79d28fa..43e3493c 100644 --- a/test-suite/success/Scopes.v +++ b/test-suite/success/Scopes.v @@ -6,3 +6,17 @@ Module A. Definition opp := Z.opp. End A. Check (A.opp 3). + +(* Test extra scopes to be used in the presence of coercions *) + +Record B := { f :> Z -> Z }. +Variable a:B. +Arguments Scope a [Z_scope]. +Check a 0. + +(* Check that casts activate scopes if ever possible *) + +Inductive U := A. +Bind Scope u with U. +Notation "'ε'" := A : u. +Definition c := ε : U. diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v index ed445c63..01d9afb4 100644 --- a/test-suite/success/Tauto.v +++ b/test-suite/success/Tauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* exist (fun x : nat => x = S (S p)) (S x) _). rewrite h. auto. @@ -184,7 +184,7 @@ Qed. -(* Quelques essais de recurrence bien fondée *) +(* Quelques essais de recurrence bien fondée *) Require Import Wf. Require Import Wf_nat. diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index 0d8bf556..21b829aa 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -164,8 +164,8 @@ intros. apply H with (y:=y). (* [x] had two possible instances: [S 0], coming from unifying the type of [y] with [I ?n] and [succ 0] coming from the unification with - the goal; only the first one allows to make the next apply (which - does not work modulo delta) working *) + the goal; only the first one allows the next apply (which + does not work modulo delta) work *) apply H0. Qed. @@ -336,25 +336,43 @@ Qed. (* From 12612, descent in conjunctions is more powerful *) (* The following, which was failing badly in bug 1980, is now properly rejected, as descend in conjunctions builds an - ill-formed elimination from Prop to Type. *) + ill-formed elimination from Prop to Type. + + Added Aug 2014: why it fails is now that trivial unification ?x = goal is + rejected by the descent in conjunctions to avoid surprising results. *) Goal True. Fail eapply ex_intro. exact I. Qed. -(* The following, which were not accepted, are now accepted as - expected by descent in conjunctions *) +Goal True. +Fail eapply (ex_intro _). +exact I. +Qed. + +(* Note: the following succeed directly (i.e. w/o "exact I") since + Aug 2014 since the descent in conjunction does not use a "cut" + anymore: the iota-redex is contracted and we get rid of the + uninstantiated evars + + Is it good or not? Maybe it does not matter so much. Goal True. eapply (ex_intro (fun _ => True) I). -exact I. +exact I. (* Not needed since Aug 2014 *) +Qed. + +Goal True. +eapply (ex_intro (fun _ => True) I _). +exact I. (* Not needed since Aug 2014 *) Qed. Goal True. eapply (fun (A:Prop) (x:A) => conj I x). -exact I. +exact I. (* Not needed since Aug 2014 *) Qed. +*) (* The following was not accepted from r12612 to r12657 *) @@ -430,3 +448,91 @@ Undo. (* H' is displayed as (forall n0, n=n0) *) apply H' with (n0:=0). Qed. + +(* Check that evars originally present in goal do not prevent apply in to work*) + +Goal (forall x, x <= 0 -> x = 0) -> exists x, x <= 0 -> 0 = 0. +intros. +eexists. +intros. +apply H in H0. +Abort. + +(* Check correct failure of apply in when hypothesis is dependent *) + +Goal forall H:0=0, H = H. +intros. +Fail apply eq_sym in H. + +(* Check that unresolved evars not originally present in goal prevent + apply in to work*) + +Goal (forall x y, x <= 0 -> x + y = 0) -> exists x, x <= 0 -> 0 = 0. +intros. +eexists. +intros. +Fail apply H in H0. +Abort. + +(* Check naming pattern in apply in *) + +Goal ((False /\ (True -> True))) -> True -> True. +intros F H. +apply F in H as H0. (* Check that H0 is not used internally *) +exact H0. +Qed. + +Goal ((False /\ (True -> True/\True))) -> True -> True/\True. +intros F H. +apply F in H as (?,?). +split. +exact H. (* Check that generated names are H and H0 *) +exact H0. +Qed. + +(* This failed at some time in between 18 August 2014 and 2 September 2014 *) + +Goal forall A B C: Prop, (True -> A -> B /\ C) -> A -> B. +intros * H. +apply H. +Abort. + +(* This failed between 2 and 3 September 2014 *) + +Goal forall A B C D:Prop, (A<->B)/\(C<->D) -> A -> B. +intros. +apply H in H0. +pose proof I as H1. (* Test that H1 does not exist *) +Abort. + +Goal forall A B C D:Prop, (A<->B)/\(C<->D) -> A. +intros. +apply H. +pose proof I as H0. (* Test that H0 does not exist *) +Abort. + +(* The first example below failed at some time in between 18 August + 2014 and 2 September 2014 *) + +Goal forall x, 2=0 -> x+1=2 -> (forall x, S x = 0) -> True. +intros x H H0 H1. +eapply eq_trans in H. 2:apply H0. +rewrite H1 in H. +change (x+0=0) in H. (* Check the result in H1 *) +Abort. + +Goal forall x, 2=x+1 -> (forall x, S x = 0) -> 2 = 0. +intros x H H0. +eapply eq_trans. apply H. +rewrite H0. +change (x+0=0). +Abort. + +(* 2nd order apply used to have delta on local definitions even though + it does not have delta on global definitions; keep it by + compatibility while finding a more uniform way to proceed. *) + +Goal forall f:nat->nat, (forall P x, P (f x)) -> let x:=f 0 in x = 0. +intros f H x. +apply H. +Qed. diff --git a/test-suite/success/applyTC.v b/test-suite/success/applyTC.v new file mode 100644 index 00000000..c2debdec --- /dev/null +++ b/test-suite/success/applyTC.v @@ -0,0 +1,15 @@ +Axiom P : nat -> Prop. + +Class class (A : Type) := { val : A }. + +Lemma usetc {t : class nat} : P (@val nat t). +Admitted. + +Notation "{val:= v }" := (@val _ v). + +Instance zero : class nat := {| val := 0 |}. + +Lemma test : P 0. +Fail apply usetc. +pose (tmp := usetc); apply tmp; clear tmp. +Qed. diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v index 9b691e25..db3b19af 100644 --- a/test-suite/success/auto.v +++ b/test-suite/success/auto.v @@ -14,7 +14,7 @@ Hint Resolve L. Goal G unit Q -> F (Q tt). intro. - auto. + eauto. Qed. (* Test implicit arguments in "using" clause *) @@ -24,3 +24,24 @@ auto using (pair O). Undo. eauto using (pair O). Qed. + +Create HintDb test discriminated. + +Parameter foo : forall x, x = x + 0. +Hint Resolve foo : test. + +Variable C : nat -> Type -> Prop. + +Variable c_inst : C 0 nat. + +Hint Resolve c_inst : test. + +Hint Mode C - + : test. +Hint Resolve c_inst : test2. +Hint Mode C + + : test2. + +Goal exists n, C n nat. +Proof. + eexists. Fail progress debug eauto with test2. + progress eauto with test. +Qed. diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v index b565183b..a70d9196 100644 --- a/test-suite/success/cc.v +++ b/test-suite/success/cc.v @@ -102,5 +102,32 @@ Proof. auto. Qed. +(* bug 2447 is now closed (PC, 2014) *) + +Section bug_2447. + +Variable T:Type. + +Record R := mkR {x:T;y:T;z:T}. + +Variables a a' b b' c c':T. + + + +Lemma bug_2447: mkR a b c = mkR a' b c -> a = a'. +congruence. +Qed. + +Lemma bug_2447_variant1: mkR a b c = mkR a b' c -> b = b'. +congruence. +Qed. + +Lemma bug_2447_variant2: mkR a b c = mkR a b c' -> c = c'. +congruence. +Qed. + + +End bug_2447. + diff --git a/test-suite/success/change.v b/test-suite/success/change.v index 7bed7ecb..1f0b7d38 100644 --- a/test-suite/success/change.v +++ b/test-suite/success/change.v @@ -38,3 +38,24 @@ Fail change True with (let (x,a) := ex_intro _ True (eq_refl True) in x). Fail change True with match ex_intro _ True (eq_refl True) with ex_intro x _ => x end. Abort. + +(* Check absence of loop in identity substitution (was failing up to + Sep 2014, see #3641) *) + +Goal True. +change ?x with x. +Abort. + +(* Check typability after change of type subterms *) +Goal nat = nat :> Set. +Fail change nat with (@id Type nat). (* would otherwise be ill-typed *) +Abort. + +(* Check typing env for rhs is the correct one *) + +Goal forall n, let x := n in id (fun n => n + x) 0 = 0. +intros. +unfold x. +(* check that n in 0+n is not interpreted as the n from "fun n" *) +change n with (0+n). +Abort. diff --git a/test-suite/success/coercions.v b/test-suite/success/coercions.v index 4292ecb6..b538d2ed 100644 --- a/test-suite/success/coercions.v +++ b/test-suite/success/coercions.v @@ -96,13 +96,13 @@ Inductive list (A : Type) : Type := nil : list A | cons : A -> list A -> list A. Inductive vect (A : Type) : nat -> Type := vnil : vect A 0 | vcons : forall n, A -> vect A n -> vect A (1+n). -Fixpoint size A (l : list A) : nat := match l with nil => 0 | cons _ tl => 1+size _ tl end. +Fixpoint size A (l : list A) : nat := match l with nil _ => 0 | cons _ _ tl => 1+size _ tl end. Section test_non_unif_but_complete. Fixpoint l2v A (l : list A) : vect A (size A l) := match l as l return vect A (size A l) with - | nil => vnil A - | cons x xs => vcons A (size A xs) x (l2v A xs) + | nil _ => vnil A + | cons _ x xs => vcons A (size A xs) x (l2v A xs) end. Local Coercion l2v : list >-> vect. @@ -121,8 +121,8 @@ Instance pair A B C D (c1 : coercion A B) (c2 : coercion C D) : coercion (A * C) Fixpoint l2v2 {A B} {c : coercion A B} (l : list A) : (vect B (size A l)) := match l as l return vect B (size A l) with - | nil => vnil B - | cons x xs => vcons _ _ (c x) (l2v2 xs) end. + | nil _ => vnil B + | cons _ x xs => vcons _ _ (c x) (l2v2 xs) end. Local Coercion l2v2 : list >-> vect. diff --git a/test-suite/success/decl_mode.v b/test-suite/success/decl_mode.v index 52575eca..58f79d45 100644 --- a/test-suite/success/decl_mode.v +++ b/test-suite/success/decl_mode.v @@ -67,7 +67,7 @@ proof. end proof. Qed. -Require Omega. +Require Import Omega. Lemma even_double_n: (forall m, even (double m)). proof. diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index fc40ea96..83a33f75 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -37,7 +37,6 @@ Goal True. case Refl || ecase Refl. Abort. - (* Submitted by B. Baydemir (bug #1882) *) Require Import List. @@ -93,3 +92,339 @@ Goal let T:=nat in forall (x:nat) (g:T -> nat), g x = 0. intros. destruct (g _). (* This was failing in at least r14571 *) Abort. + +(* Check that subterm selection does not solve existing evars *) + +Goal exists x, S x = S 0. +eexists. +destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) +change (0 = S 0). +Abort. + +Goal exists x, S 0 = S x. +eexists. +destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) +change (0 = S ?x). +Abort. + +Goal exists n p:nat, (S n,S n) = (S p,S p) /\ p = n. +do 2 eexists. +destruct (_, S _). (* Was unifying at some time in trunk, now takes the first occurrence *) +change ((n, n0) = (S ?p, S ?p) /\ ?p = ?n). +Abort. + +(* An example with incompatible but convertible occurrences *) + +Goal id (id 0) = 0. +Fail destruct (id _) at 1 2. +Abort. + +(* Avoid unnatural selection of a subterm larger than expected *) + +Goal let g := fun x:nat => x in g (S 0) = 0. +intro. +destruct S. +(* Check that it is not the larger subterm "g (S 0)" which is + selected, as it was the case in 8.4 *) +unfold g at 1. +Abort. + +(* Some tricky examples convenient to support *) + +Goal forall x, nat_rect (fun _ => nat) O (fun x y => S x) x = nat_rect (fun _ => nat) O (fun x y => S x) x. +intros. +destruct (nat_rect _ _ _ _). +Abort. +(* Check compatibility in selecting what is open or "shelved" *) + +Goal (forall x, x=0 -> nat) -> True. +intros. +Fail destruct H. +edestruct H. +- reflexivity. +- exact Logic.I. +- exact Logic.I. +Qed. + +(* Check an example which was working with case/elim in 8.4 but not with + destruct/induction *) + +Goal forall x, (True -> x = 0) -> 0=0. +intros. +destruct H. +- trivial. +- apply (eq_refl x). +Qed. + +(* Check an example which was working with case/elim in 8.4 but not with + destruct/induction (not the different order between induction/destruct) *) + +Goal forall x, (True -> x = 0) -> 0=0. +intros. +induction H. +- apply (eq_refl x). +- trivial. +Qed. + +(* This test assumes that destruct/induction on non-dependent hypotheses behave the same + when using holes or not + +Goal forall x, (True -> x = 0) -> 0=0. +intros. +destruct (H _). +- apply I. +- apply (eq_refl x). +Qed. +*) + +(* Check destruct vs edestruct *) + +Goal forall x, (forall y, y = 0 -> x = 0) -> 0=0. +intros. +Fail destruct H. +edestruct H. +- trivial. +- apply (eq_refl x). +Qed. + +Goal forall x, (forall y, y = 0 -> x = 0) -> 0=0. +intros. +Fail destruct (H _ _). +(* Now a test which assumes that edestruct on non-dependent + hypotheses accept unresolved subterms in the induction argument. +edestruct (H _ _). +- trivial. +- apply (eq_refl x). +Qed. +*) +Abort. + +(* Test selection when not in an inductive type *) +Parameter T:Type. +Axiom elim: forall P, T -> P. +Goal forall a:T, a = a. +induction a using elim. +Qed. + +Goal forall a:nat -> T, a 0 = a 1. +intro a. +induction (a 0) using elim. +Qed. + +(* From Oct 2014, a subterm is found, as if without "using"; in 8.4, + it did not find a subterm *) + +Goal forall a:nat -> T, a 0 = a 1. +intro a. +induction a using elim. +Qed. + +Goal forall a:nat -> T, forall b, a 0 = b. +intros a b. +induction a using elim. +Qed. + +(* From Oct 2014, first subterm is found; in 8.4, it failed because it + found "a 0" and wanted to clear a *) + +Goal forall a:nat -> nat, a 0 = a 1. +intro a. +destruct a. +change (0 = a 1). +Abort. + +(* This example of a variable not fully applied in the goal was working in 8.4*) + +Goal forall H : 0<>0, H = H. +destruct H. +reflexivity. +Qed. + +(* Check that variables not fully applied in the goal are not erased + (this example was failing in 8.4 because of a forbidden "clear H" in + the code of "destruct H" *) + +Goal forall H : True -> True, H = H. +destruct H. +- exact I. +- reflexivity. +Qed. + +(* Check destruct on idents with maximal implicit arguments - which did + not work in 8.4 *) + +Parameter g : forall {n:nat}, n=n -> nat. +Goal g (eq_refl 0) = 0. +destruct g. +Abort. + +(* This one was working in 8.4 (because of full conv on closed arguments) *) + +Class E. +Instance a:E. +Goal forall h : E -> nat -> nat, h (id a) 0 = h a 0. +intros. +destruct (h _). +change (0=0). +Abort. + +(* This one was not working in 8.4 because an occurrence of f was + remaining, blocking the "clear f" *) + +Goal forall h : E -> nat -> nat, h a 0 = h a 1. +intros. +destruct h. +Abort. + +(* This was not working in 8.4 *) + +Section S1. +Variables x y : Type. +Variable H : x = y. +Goal True. +destruct H. (* Was not working in 8.4 *) +(* Now check that H statement has itself be subject of the rewriting *) +change (x=x) in H. +Abort. +End S1. + +(* This was not working in 8.4 because of untracked dependencies *) +Goal forall y, forall h:forall x, x = y, h 0 = h 0. +intros. +destruct (h 0). +Abort. + +(* Check absence of useless local definitions *) + +Section S2. +Variable H : 1=1. +Goal 0=1. +destruct H. +Fail clear n. (* Check that there is no n as it was in Coq <= 8.4 *) +Abort. +End S2. + +Goal forall x:nat, x=x->x=1. +intros x H. +destruct H. +Fail clear n. (* Check that there is no n as it was in Coq <= 8.4 *) +Fail clear H. (* Check that H has been removed *) +Abort. + +(* Check support for induction arguments which do not expose an inductive + type rightaway *) + +Definition U := nat -> nat. +Definition S' := S : U. +Goal forall n, S' n = 0. +intro. +destruct S'. +Abort. + +(* This was working by chance in 8.4 thanks to "accidental" use of select + subterms _syntactically_ equal to the first matching one. + +Parameter f2:bool -> unit. +Parameter r2:f2 true=f2 true. +Goal forall (P: forall b, b=b -> Prop), f2 (id true) = tt -> P (f2 true) r2. +intros. +destruct f2. +Abort. +*) + +(* This did not work in 8.4, because of a clear failing *) + +Inductive IND : forall x y:nat, x=y -> Type := CONSTR : IND 0 0 eq_refl. +Goal forall x y e (h:x=y -> y=x) (z:IND y x (h e)), e = e /\ z = z. +intros. +destruct z. +Abort. + +(* The two following examples show how the variables occurring in the + term being destruct affects the generalization; don't know if these + behaviors are "good". None of them was working in 8.4. *) + +Goal forall x y e (t:x=y) (z:x=y -> IND y x e), e = e. +intros. +destruct (z t). +change (0=0) in t. (* Generalization made *) +Abort. + +Goal forall x y e (t:x=y) (z:x=y -> IND y x e), e = e /\ z t = z t. +intros. +destruct (z t). +change (0=0) in t. (* Generalization made *) +Abort. + +(* Check that destruct on a scheme with a functional argument works *) + +Goal (forall P:Prop, (nat->nat) -> P) -> forall h:nat->nat, h 0 = h 0. +intros. +destruct h using H. +Qed. + +Goal (forall P:Prop, (nat->nat) -> P) -> forall h:nat->nat->nat, h 0 0 = h 1 0. +intros. +induction (h 1) using H. +Qed. + +(* Check blocking generalization is not too strong (failed at some time) *) + +Goal (E -> 0=1) -> 1=0 -> True. +intros. +destruct (H _). +change (0=0) in H0. (* Check generalization on H0 was made *) +Abort. + +(* Check absence of anomaly (failed at some time) *) + +Goal forall A (a:A) (P Q:A->Prop), (forall a, P a -> Q a) -> True. +intros. +Fail destruct H. +Abort. + +(* Check keep option (bug #3791) *) + +Goal forall b:bool, True. +intro b. +destruct !b. +clear b. (* b has to be here *) +Abort. + +(* Check clearing of names *) + +Inductive IND2 : nat -> Prop := CONSTR2 : forall y, y = y -> IND2 y. +Goal forall x y z:nat, y = z -> x = y -> y = x -> x = y. +intros * Heq H Heq'. +destruct H. +Abort. + +Goal 2=1 -> 1=0. +intro H. destruct H. +Fail (match goal with n:nat |- _ => unfold n end). (* Check that no let-in remains *) +Abort. + +(* Check clearing of names *) + +Inductive eqnat (x : nat) : nat -> Prop := + reflnat : forall y, x = y -> eqnat x y. + +Goal forall x z:nat, x = z -> eqnat x z -> True. +intros * H1 H. +destruct H. +Fail clear z. (* Should not be here *) +Abort. + +(* Check ok in the presence of an equation *) + +Goal forall b:bool, b = b. +intros. +destruct b eqn:H. + +(* Check natural instantiation behavior when the goal has already an evar *) + +Goal exists x, S x = x. +eexists. +destruct (S _). +change (0 = ?x). +Abort. diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v index b7b0f7fd..9e57801e 100644 --- a/test-suite/success/eauto.v +++ b/test-suite/success/eauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Set. Variable cons : forall T : Set, T -> list T -> list T. @@ -44,13 +45,13 @@ Fixpoint build (nl : list nat) : (* Checks that disjoint contexts are correctly set by restrict_hyp *) -(* Bug de 1999 corrigé en déc 2004 *) +(* Bug de 1999 corrigé en déc 2004 *) Check (let p := fun (m : nat) f (n : nat) => match f m n with - | exist a b => exist _ a b + | exist _ a b => exist _ a b end in p :forall x : nat, @@ -61,7 +62,7 @@ Check Check (fun f:(forall (v:Type->Type), v (v nat) -> nat) => f _ (Some (Some O))). -(* This used to fail with anomaly "evar was not declared" in V8.0pl3 *) +(* This used to fail with anomaly (Pp.str "evar was not declared") in V8.0pl3 *) Theorem contradiction : forall p, ~ p -> p -> False. Proof. trivial. Qed. @@ -177,9 +178,9 @@ refine | left _ => _ | right _ => match le_step s _ _ with - | exist s' h' => + | exist _ s' h' => match hr s' _ _ with - | exist s'' _ => exist _ s'' _ + | exist _ s'' _ => exist _ s'' _ end end end)). @@ -203,7 +204,7 @@ Abort. Fixpoint filter (A:nat->Set) (l:list (sigT A)) : list (sigT A) := match l with | nil => nil - | (existT k v)::l' => (existT _ k v):: (filter A l') + | (existT _ k v)::l' => (existT _ k v):: (filter A l') end. (* Bug #2000: used to raise Out of memory in 8.2 while it should fail by @@ -379,3 +380,38 @@ Section evar_evar_occur. (* Still evars in the resulting type, but constraints should be solved *) Check match g _ with conj a b => f _ a b end. End evar_evar_occur. + +(* Eta expansion (bug #2936) *) +Record iffT (X Y:Type) : Type := mkIff { iffLR : X->Y; iffRL : Y->X }. +Record tri (R:Type->Type->Type) (S:Type->Type->Type) (T:Type->Type->Type) := mkTri { + tri0 : forall a b c, R a b -> S a c -> T b c +}. +Implicit Arguments mkTri [R S T]. +Definition tri_iffT : tri iffT iffT iffT := + (mkTri + (fun X0 X1 X2 E01 E02 => + (mkIff _ _ (fun x1 => iffLR _ _ E02 (iffRL _ _ E01 x1)) + (fun x2 => iffLR _ _ E01 (iffRL _ _ E02 x2))))). + +(* Check that local defs names are preserved if possible during unification *) + +Goal forall x (x':=x) (f:forall y, y=y:>nat -> Prop), f _ (eq_refl x'). +intros. +unfold x' at 2. (* A way to check that there are indeed 2 occurrences of x' *) +Abort. + +(* A simple example we would like not to fail (it used to fail because of + not strict enough evar restriction) *) + +Check match Some _ with None => _ | _ => _ end. + +(* Used to fail for a couple of days in Nov 2014 *) + +Axiom test : forall P1 P2, P1 = P2 -> P1 -> P2. + +(* Check use of candidates *) + +Import EqNotations. +Definition test2 {A B:Type} {H:A=B} (a:A) : B := rew H in a. + + diff --git a/test-suite/success/extraction.v b/test-suite/success/extraction.v index eaed9616..57f3775d 100644 --- a/test-suite/success/extraction.v +++ b/test-suite/success/extraction.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* rNat -> rNat. +Proof. intros n m; case (rltDec n m); intros Rlt0. exact m. exact n. diff --git a/test-suite/success/implicit.v b/test-suite/success/implicit.v index e8019a90..a0981311 100644 --- a/test-suite/success/implicit.v +++ b/test-suite/success/implicit.v @@ -61,7 +61,7 @@ Check (eq1 0 0). Check (eq2 0 0). Check (eq3 nat 0 0). -(* Example submitted by Frédéric (interesting in v8 syntax) *) +(* Example submitted by Frédéric (interesting in v8 syntax) *) Parameter f : nat -> nat * nat. Notation lhs := fst. diff --git a/test-suite/success/indelim.v b/test-suite/success/indelim.v new file mode 100644 index 00000000..91b6dee2 --- /dev/null +++ b/test-suite/success/indelim.v @@ -0,0 +1,61 @@ +Inductive boolP : Prop := +| trueP : boolP +| falseP : boolP. + +Fail Check boolP_rect. + + +Inductive True : Prop := I : True. + +Inductive False : Prop :=. + +Inductive Empty_set : Set :=. + +Fail Inductive Large_set : Set := + large_constr : forall A : Set, A -> Large_set. + +Inductive smallunitProp : Prop := +| onlyProps : True -> smallunitProp. + +Check smallunitProp_rect. + +Inductive nonsmallunitProp : Prop := +| notonlyProps : nat -> nonsmallunitProp. + +Fail Check nonsmallunitProp_rect. +Set Printing Universes. +Inductive inferProp := +| hasonlyProps : True -> nonsmallunitProp -> inferProp. + +Check (inferProp : Prop). + +Inductive inferSet := +| hasaset : nat -> True -> nonsmallunitProp -> inferSet. + +Fail Check (inferSet : Prop). + +Check (inferSet : Set). + +Inductive inferLargeSet := +| hasalargeset : Set -> True -> nonsmallunitProp -> inferLargeSet. + +Fail Check (inferLargeSet : Set). + +Inductive largeProp : Prop := somelargeprop : Set -> largeProp. + + +Inductive comparison : Set := + | Eq : comparison + | Lt : comparison + | Gt : comparison. + +Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type := + | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq + | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt + | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt. + +Inductive color := Red | Black. + +Inductive option (A : Type) : Type := +| None : option A +| Some : A -> option A. \ No newline at end of file diff --git a/test-suite/success/inds_type_sec.v b/test-suite/success/inds_type_sec.v index 83c90929..b733aef6 100644 --- a/test-suite/success/inds_type_sec.v +++ b/test-suite/success/inds_type_sec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Type) (f : P True I) (A : Type) => let B := A in fun (a : A) (e : eq1 A a) => - match e in (eq1 A0 B0 a0) return (P A0 a0) with + match e in (eq1 A0 a0) return (P A0 a0) with | refl1 => f end. @@ -64,3 +64,90 @@ Undo 2. Fail induction (S _) in |- * at 4. Abort. +(* Check use of "as" clause *) + +Inductive I := C : forall x, x<0 -> I -> I. + +Goal forall x:I, x=x. +intros. +induction x as [y * IHx]. +change (x = x) in IHx. (* We should have IHx:x=x *) +Abort. + +(* This was not working in 8.4 *) + +Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. +intros. +induction h. +2:change (n = h 1 -> n = h 2) in IHn. +Abort. + +(* This was not working in 8.4 *) + +Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. +intros h H H0. +induction h in H |- *. +Abort. + +(* "at" was not granted in 8.4 in the next two examples *) + +Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. +intros h H H0. +induction h in H at 2, H0 at 1. +change (h 0 = 0) in H. +Abort. + +Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. +intros h H H0. +Fail induction h in H at 2 |- *. (* Incompatible occurrences *) +Abort. + +(* Check generalization with dependencies in section variables *) + +Section S3. +Variables x : nat. +Definition cond := x = x. +Goal cond -> x = 0. +intros H. +induction x as [|n IHn]. +2:change (n = 0) in IHn. (* We don't want a generalization over cond *) +Abort. +End S3. + +(* These examples show somehow arbitrary choices of generalization wrt + to indices, when those indices are not linear. We check here 8.4 + compatibility: when an index is a subterm of a parameter of the + inductive type, it is not generalized. *) + +Inductive repr (x:nat) : nat -> Prop := reprc z : repr x z -> repr x z. + +Goal forall x, 0 = x -> repr x x -> True. +intros x H1 H. +induction H. +change True in IHrepr. +Abort. + +Goal forall x, 0 = S x -> repr (S x) (S x) -> True. +intros x H1 H. +induction H. +change True in IHrepr. +Abort. + +Inductive repr' (x:nat) : nat -> Prop := reprc' z : repr' x (S z) -> repr' x z. + +Goal forall x, 0 = x -> repr' x x -> True. +intros x H1 H. +induction H. +change True in IHrepr'. +Abort. + +(* In this case, generalization was done in 8.4 and we preserve it; this + is arbitrary choice *) + +Inductive repr'' : nat -> nat -> Prop := reprc'' x z : repr'' x z -> repr'' x z. + +Goal forall x, 0 = x -> repr'' x x -> True. +intros x H1 H. +induction H. +change (0 = z -> True) in IHrepr''. +Abort. diff --git a/test-suite/success/instantiate.v b/test-suite/success/instantiate.v deleted file mode 100644 index 4224405d..00000000 --- a/test-suite/success/instantiate.v +++ /dev/null @@ -1,11 +0,0 @@ -(* Test régression bug #1041 *) - -Goal Prop. - -pose (P:= fun x y :Prop => y). -evar (Q: forall X Y,P X Y -> Prop) . - -instantiate (1:= fun _ => _ ) in (Value of Q). -instantiate (1:= fun _ => _ ) in (Value of Q). -instantiate (1:= fun _ => _ ) in (Value of Q). -instantiate (1:= H) in (Value of Q). diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 3599da4d..9443d01e 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -3,5 +3,33 @@ Goal forall A, A -> True. intros _ _. +Abort. +(* This did not work until March 2013, because of underlying "red" *) +Goal (fun x => True -> True) 0. +intro H. +Abort. +(* This should still work, with "intro" calling "hnf" *) +Goal (fun f => True -> f 0 = f 0) (fun x => x). +intro H. +match goal with [ |- 0 = 0 ] => reflexivity end. +Abort. + +(* Somewhat related: This did not work until March 2013 *) +Goal (fun f => f 0 = f 0) (fun x => x). +hnf. +match goal with [ |- 0 = 0 ] => reflexivity end. +Abort. + +(* Fixing behavior of "*" and "**" in branches, so that they do not + introduce more than what the branch expects them to introduce at most *) +Goal forall n p, n + p = 0. +intros [|*]; intro p. +Abort. + +(* Check non-interference of "_" with name generation *) +Goal True -> True -> True. +intros _ ?. +exact H. +Qed. diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v new file mode 100644 index 00000000..bbe9d4bf --- /dev/null +++ b/test-suite/success/keyedrewrite.v @@ -0,0 +1,24 @@ +Set Keyed Unification. + +Section foo. +Variable f : nat -> nat. + +Definition g := f. + +Variable lem : g 0 = 0. + +Goal f 0 = 0. +Proof. + Fail rewrite lem. +Abort. + +Declare Equivalent Keys @g @f. +(** Now f and g are considered equivalent heads for subterm selection *) +Goal f 0 = 0. +Proof. + rewrite lem. + reflexivity. +Qed. + +Print Equivalent Keys. +End foo. diff --git a/test-suite/success/letproj.v b/test-suite/success/letproj.v new file mode 100644 index 00000000..a183be62 --- /dev/null +++ b/test-suite/success/letproj.v @@ -0,0 +1,9 @@ +Set Primitive Projections. +Set Record Elimination Schemes. +Record Foo (A : Type) := { bar : A -> A; baz : A }. + +Definition test (A : Type) (f : Foo A) := + let (x, y) := f in x. + +Scheme foo_case := Case for Foo Sort Type. + diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index c2eb8bd7..badce063 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -1,6 +1,6 @@ (* The tactic language *) -(* Submitted by Pierre Crégut *) +(* Submitted by Pierre Crégut *) (* Checks substitution of x *) Ltac f x := unfold x; idtac. @@ -9,7 +9,7 @@ f plus. reflexivity. Qed. -(* Submitted by Pierre Crégut *) +(* Submitted by Pierre Crégut *) (* Check syntactic correctness *) Ltac F x := idtac; G x with G y := idtac; F y. @@ -143,7 +143,7 @@ Qed. Ltac check_binding y := cut ((fun y => y) = S). Goal True. -check_binding true. +check_binding ipattern:H. Abort. (* Check that variables explicitly parsed as ltac variables are not @@ -211,7 +211,7 @@ is. exact I. Abort. -(* Interférence entre espaces des noms *) +(* Interférence entre espaces des noms *) Ltac O := intro. Ltac Z1 t := set (x:=t). @@ -298,7 +298,3 @@ evar(foo:nat). let evval := eval compute in foo in not_eq evval 1. let evval := eval compute in foo in not_eq 1 evval. Abort. - -(* Check that this returns an error and not an anomaly (see r13667) *) - -Fail Local Tactic Notation "myintro" := intro. diff --git a/test-suite/success/ltac_plus.v b/test-suite/success/ltac_plus.v new file mode 100644 index 00000000..8a08d646 --- /dev/null +++ b/test-suite/success/ltac_plus.v @@ -0,0 +1,12 @@ +(** Checks that Ltac's '+' tactical works as intended. *) + +Goal forall (A B C D:Prop), (A->C) -> (B->C) -> (D->C) -> B -> C. +Proof. + intros A B C D h0 h1 h2 h3. + (* backtracking *) + (apply h0 + apply h1);apply h3. + Undo. + Fail ((apply h0+apply h2) || apply h1); apply h3. + (* interaction with || *) + ((apply h0+apply h1) || apply h2); apply h3. +Qed. \ No newline at end of file diff --git a/test-suite/success/mutual_ind.v b/test-suite/success/mutual_ind.v index 05303f37..54cfa658 100644 --- a/test-suite/success/mutual_ind.v +++ b/test-suite/success/mutual_ind.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Type := idpath : paths x x where "x = y" := (@paths _ x y) : type_scope. *) +(* Goal forall A B : Set, @paths Type A B -> @paths Set A B. *) +(* intros A B H. *) +(* Fail exact H. *) +(* Section . *) + +Section lift_strict. +Polymorphic Definition liftlt := + let t := Type@{i} : Type@{k} in + fun A : Type@{i} => A : Type@{k}. + +Polymorphic Definition liftle := + fun A : Type@{i} => A : Type@{k}. +End lift_strict. + + +Set Universe Polymorphism. + +(* Inductive option (A : Type) : Type := *) +(* | None : option A *) +(* | Some : A -> option A. *) + +Inductive option (A : Type@{i}) : Type@{i} := + | None : option A + | Some : A -> option A. + +Definition foo' {A : Type@{i}} (o : option@{i} A) : option@{i} A := + o. + +Definition foo'' {A : Type@{i}} (o : option@{j} A) : option@{k} A := + o. + + +Definition testm (A : Type@{i}) : Type@{max(i,j)} := A. + +(* Inductive prod (A : Type@{i}) (B : Type@{j}) := *) +(* | pair : A -> B -> prod A B. *) + +(* Definition snd {A : Type@{i}} (B : Type@{j}) (p : prod A B) : B := *) +(* match p with *) +(* | pair _ _ a b => b *) +(* end. *) + +(* Definition snd' {A : Type@{i}} (B : Type@{i}) (p : prod A B) : B := *) +(* match p with *) +(* | pair _ _ a b => b *) +(* end. *) + +(* Inductive paths {A : Type} : A -> A -> Type := *) +(* | idpath (a : A) : paths a a. *) + +Inductive paths {A : Type@{i}} : A -> A -> Type@{i} := +| idpath (a : A) : paths a a. + +Definition Funext := + forall (A : Type) (B : A -> Type), + forall f g : (forall a, B a), (forall x : A, paths (f x) (g x)) -> paths f g. + +Definition paths_lift_closed (A : Type@{i}) (x y : A) : + paths x y -> @paths (liftle@{j Type} A) x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_lift (A : Type@{i}) (x y : A) : + paths x y -> paths@{j} x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_lift_closed_strict (A : Type@{i}) (x y : A) : + paths x y -> @paths (liftlt@{j Type} A) x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_downward_closed_le (A : Type@{i}) (x y : A) : + paths@{j} (A:=liftle@{i j} A) x y -> paths@{i} x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_downward_closed_lt (A : Type@{i}) (x y : A) : + @paths (liftlt@{j i} A) x y -> paths x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_downward_closed_lt_nolift (A : Type@{i}) (x y : A) : + paths@{j} x y -> paths x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition funext_downward_closed (F : Funext@{i' j' k'}) : + Funext@{i j k}. +Proof. + intros A B f g H. red in F. + pose (F A B f g (fun x => paths_lift _ _ _ (H x))). + apply paths_downward_closed_lt_nolift. apply p. +Defined. + diff --git a/test-suite/success/paralleltac.v b/test-suite/success/paralleltac.v new file mode 100644 index 00000000..94ff96ef --- /dev/null +++ b/test-suite/success/paralleltac.v @@ -0,0 +1,46 @@ +Fixpoint fib n := match n with + | O => 1 + | S m => match m with + | O => 1 + | S o => fib o + fib m end end. +Ltac sleep n := + try (assert (fib n = S (fib n)) by reflexivity). +(* Tune that depending on your PC *) +Let time := 18. + +Axiom P : nat -> Prop. +Axiom P_triv : Type -> forall x, P x. +Ltac solve_P := + match goal with |- P (S ?X) => + sleep time; exact (P_triv Type _) + end. + +Lemma test_old x : P (S x) /\ P (S x) /\ P (S x) /\ P (S x). +Proof. +repeat split. +idtac "T1: linear". +Time all: solve_P. +Qed. + +Lemma test_ok x : P (S x) /\ P (S x) /\ P (S x) /\ P (S x). +Proof. +repeat split. +idtac "T2: parallel". +Time par: solve_P. +Qed. + +Lemma test_fail x : P (S x) /\ P x /\ P (S x) /\ P (S x). +Proof. +repeat split. +idtac "T3: linear failure". +Fail Time all: solve_P. +all: apply (P_triv Type). +Qed. + +Lemma test_fail2 x : P (S x) /\ P x /\ P (S x) /\ P (S x). +Proof. +repeat split. +idtac "T4: parallel failure". +Fail Time par: solve_P. +all: apply (P_triv Type). +Qed. diff --git a/test-suite/success/params_ind.v b/test-suite/success/params_ind.v deleted file mode 100644 index 1bee31c8..00000000 --- a/test-suite/success/params_ind.v +++ /dev/null @@ -1,4 +0,0 @@ -Inductive list (A : Set) : Set := - | nil : list A - | cons : A -> list (A -> A) -> list A. - diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index 56cab0f6..9167c9fc 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -1,12 +1,294 @@ +Module withoutpoly. + +Inductive empty :=. + +Inductive emptyt : Type :=. +Inductive singleton : Type := + single. +Inductive singletoninfo : Type := + singleinfo : unit -> singletoninfo. +Inductive singletonset : Set := + singleset. + +Inductive singletonnoninfo : Type := + singlenoninfo : empty -> singletonnoninfo. + +Inductive singletoninfononinfo : Prop := + singleinfononinfo : unit -> singletoninfononinfo. + +Inductive bool : Type := + | true | false. + +Inductive smashedbool : Prop := + | trueP | falseP. +End withoutpoly. + +Set Universe Polymorphism. + +Inductive empty :=. +Inductive emptyt : Type :=. +Inductive singleton : Type := + single. +Inductive singletoninfo : Type := + singleinfo : unit -> singletoninfo. +Inductive singletonset : Set := + singleset. + +Inductive singletonnoninfo : Type := + singlenoninfo : empty -> singletonnoninfo. + +Inductive singletoninfononinfo : Prop := + singleinfononinfo : unit -> singletoninfononinfo. + +Inductive bool : Type := + | true | false. + +Inductive smashedbool : Prop := + | trueP | falseP. + +Section foo. + Let T := Type. + Inductive polybool : T := + | trueT | falseT. +End foo. + +Inductive list (A: Type) : Type := +| nil : list A +| cons : A -> list A -> list A. + +Module ftypSetSet. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : ftyp -> area +. +End ftypSetSet. + + +Module ftypSetProp. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : (* ftyp -> *)area +. +End ftypSetProp. + +Module ftypSetSetForced. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Set (* Type *) := + | Stored : (* ftyp -> *)area +. +End ftypSetSetForced. + +Unset Universe Polymorphism. + +Set Printing Universes. +Module Easy. + + Polymorphic Inductive prod (A : Type) (B : Type) : Type := + pair : A -> B -> prod A B. + + Check prod nat nat. + Print Universes. + + + Polymorphic Inductive sum (A B:Type) : Type := + | inl : A -> sum A B + | inr : B -> sum A B. + Print sum. + Check (sum nat nat). + +End Easy. + +Section Hierarchy. + +Definition Type3 := Type. +Definition Type2 := Type : Type3. +Definition Type1 := Type : Type2. + +Definition id1 := ((forall A : Type1, A) : Type2). +Definition id2 := ((forall A : Type2, A) : Type3). +Definition id1' := ((forall A : Type1, A) : Type3). +Fail Definition id1impred := ((forall A : Type1, A) : Type1). + +End Hierarchy. + +Section structures. + +Record hypo : Type := mkhypo { + hypo_type : Type; + hypo_proof : hypo_type + }. + +Definition typehypo (A : Type) : hypo := {| hypo_proof := A |}. + +Polymorphic Record dyn : Type := + mkdyn { + dyn_type : Type; + dyn_proof : dyn_type + }. + +Definition monotypedyn (A : Type) : dyn := {| dyn_proof := A |}. +Polymorphic Definition typedyn (A : Type) : dyn := {| dyn_proof := A |}. + +Definition atypedyn : dyn := typedyn Type. + +Definition projdyn := dyn_type atypedyn. + +Definition nested := {| dyn_type := dyn; dyn_proof := atypedyn |}. + +Definition nested2 := {| dyn_type := dyn; dyn_proof := nested |}. + +Definition projnested2 := dyn_type nested2. + +Polymorphic Definition nest (d : dyn) := {| dyn_proof := d |}. + +Polymorphic Definition twoprojs (d : dyn) := dyn_proof d = dyn_proof d. + +End structures. + +Section cats. + Local Set Universe Polymorphism. + Require Import Utf8. + Definition fibration (A : Type) := A -> Type. + Definition Hom (A : Type) := A -> A -> Type. + + Record sigma (A : Type) (P : fibration A) := + { proj1 : A; proj2 : P proj1} . + + Class Identity {A} (M : Hom A) := + identity : ∀ x, M x x. + + Class Inverse {A} (M : Hom A) := + inverse : ∀ x y:A, M x y -> M y x. + + Class Composition {A} (M : Hom A) := + composition : ∀ {x y z:A}, M x y -> M y z -> M x z. + + Notation "g ° f" := (composition f g) (at level 50). + + Class Equivalence T (Eq : Hom T):= + { + Equivalence_Identity :> Identity Eq ; + Equivalence_Inverse :> Inverse Eq ; + Equivalence_Composition :> Composition Eq + }. + + Class EquivalenceType (T : Type) : Type := + { + m2: Hom T; + equiv_struct :> Equivalence T m2 }. + + Polymorphic Record cat (T : Type) := + { cat_hom : Hom T; + cat_equiv : forall x y, EquivalenceType (cat_hom x y) }. + + Definition catType := sigma Type cat. + + Notation "[ T ]" := (proj1 T). + + Require Import Program. + + Program Definition small_cat : cat Empty_set := + {| cat_hom x y := unit |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Record iso (T U : Set) := + { f : T -> U; + g : U -> T }. + + Program Definition Set_cat : cat Set := + {| cat_hom := iso |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Record isoT (T U : Type) := + { isoT_f : T -> U; + isoT_g : U -> T }. + + Program Definition Type_cat : cat Type := + {| cat_hom := isoT |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Polymorphic Record cat1 (T : Type) := + { cat1_car : Type; + cat1_hom : Hom cat1_car; + cat1_hom_cat : forall x y, cat (cat1_hom x y) }. +End cats. + +Polymorphic Definition id {A : Type} (a : A) : A := a. + +Definition typeid := (@id Type). + + +Fail Check (Prop : Set). +Fail Check (Set : Set). +Check (Set : Type). +Check (Prop : Type). +Definition setType := $(let t := type of Set in exact t)$. + +Definition foo (A : Prop) := A. + +Fail Check foo Set. +Check fun A => foo A. +Fail Check fun A : Type => foo A. +Check fun A : Prop => foo A. +Fail Definition bar := fun A : Set => foo A. + +Fail Check (let A := Type in foo (id A)). + +Definition fooS (A : Set) := A. + +Check (let A := nat in fooS (id A)). +Fail Check (let A := Set in fooS (id A)). +Fail Check (let A := Prop in fooS (id A)). + (* Some tests of sort-polymorphisme *) Section S. -Variable A:Type. +Polymorphic Variable A:Type. (* Definition f (B:Type) := (A * B)%type. *) -Inductive I (B:Type) : Type := prod : A->B->I B. +Polymorphic Inductive I (B:Type) : Type := prod : A->B->I B. + +Check I nat. + End S. (* Check f nat nat : Set. *) -Check I nat nat : Set. \ No newline at end of file +Definition foo' := I nat nat. +Print Universes. Print foo. Set Printing Universes. Print foo. + +(* Polymorphic axioms: *) +Polymorphic Axiom funext : forall (A B : Type) (f g : A -> B), + (forall x, f x = g x) -> f = g. + +(* Check @funext. *) +(* Check funext. *) + +Polymorphic Definition fun_ext (A B : Type) := + forall (f g : A -> B), + (forall x, f x = g x) -> f = g. + +Polymorphic Class Funext A B := extensional : fun_ext A B. + +Section foo2. + Context `{forall A B, Funext A B}. + Print Universes. +End foo2. diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v new file mode 100644 index 00000000..068f8ac3 --- /dev/null +++ b/test-suite/success/primitiveproj.v @@ -0,0 +1,190 @@ +Set Primitive Projections. +Set Record Elimination Schemes. +Module Prim. + +Record F := { a : nat; b : a = a }. +Record G (A : Type) := { c : A; d : F }. + +Check c. +End Prim. +Module Univ. +Set Universe Polymorphism. +Set Implicit Arguments. +Record Foo (A : Type) := { foo : A }. + +Record G (A : Type) := { c : A; d : c = c; e : Foo A }. + +Definition Foon : Foo nat := {| foo := 0 |}. + +Definition Foonp : nat := Foon.(foo). + +Definition Gt : G nat := {| c:= 0; d:=eq_refl; e:= Foon |}. + +Check (Gt.(e)). + +Section bla. + + Record bar := { baz : nat; def := 0; baz' : forall x, x = baz \/ x = def }. +End bla. + +End Univ. + +Set Primitive Projections. +Unset Elimination Schemes. +Set Implicit Arguments. + +Check nat. + +(* Inductive X (U:Type) := Foo (k : nat) (x : X U). *) +(* Parameter x : X nat. *) +(* Check x.(k). *) + +Inductive X (U:Type) := { k : nat; a: k = k -> X U; b : let x := a eq_refl in X U }. + +Parameter x:X nat. +Check (a x : forall _ : @eq nat (k x) (k x), X nat). +Check (b x : X nat). + +Inductive Y := { next : option Y }. + +Check _.(next) : option Y. +Lemma eta_ind (y : Y) : y = Build_Y y.(next). +Proof. reflexivity. Defined. + +Variable t : Y. + +Fixpoint yn (n : nat) (y : Y) : Y := + match n with + | 0 => t + | S n => {| next := Some (yn n y) |} + end. + +Lemma eta_ind' (y: Y) : Some (yn 100 y) = Some {| next := (yn 100 y).(next) |}. +Proof. reflexivity. Defined. + + +(* + Rules for parsing and printing of primitive projections and their eta expansions. + If r : R A where R is a primitive record with implicit parameter A. + If p : forall {A} (r : R A) {A : Set}, list (A * B). +*) + +Record R {A : Type} := { p : forall {X : Set}, A * X }. +Arguments R : clear implicits. + +Record R' {A : Type} := { p' : forall X : Set, A * X }. +Arguments R' : clear implicits. + +Unset Printing All. + +Parameter r : R nat. + +Check (r.(p)). +Set Printing Projections. +Check (r.(p)). +Unset Printing Projections. +Set Printing All. +Check (r.(p)). +Unset Printing All. + +(* Check (r.(p)). + Elaborates to a primitive application, X arg implicit. + Of type nat * ?ex + No Printing All: p r + Set Printing Projections.: r.(p) + Printing All: r.(@p) ?ex + *) + +Check p r. +Set Printing Projections. +Check p r. +Unset Printing Projections. +Set Printing All. +Check p r. +Unset Printing All. + +Check p r (X:=nat). +Set Printing Projections. +Check p r (X:=nat). +Unset Printing Projections. +Set Printing All. +Check p r (X:=nat). +Unset Printing All. + +(* Same elaboration, printing for p r *) + +(** Explicit version of the primitive projection, under applied w.r.t implicit arguments + can be printed only using projection notation. r.(@p) *) +Check r.(@p _). +Set Printing Projections. +Check r.(@p _). +Unset Printing Projections. +Set Printing All. +Check r.(@p _). +Unset Printing All. + +(** Explicit version of the primitive projection, applied to its implicit arguments + can be printed using application notation r.(p), r.(@p) in fully explicit form *) +Check r.(@p _) nat. +Set Printing Projections. +Check r.(@p _) nat. +Unset Printing Projections. +Set Printing All. +Check r.(@p _) nat. +Unset Printing All. + +Parameter r' : R' nat. + +Check (r'.(p')). +Set Printing Projections. +Check (r'.(p')). +Unset Printing Projections. +Set Printing All. +Check (r'.(p')). +Unset Printing All. + +(* Check (r'.(p')). + Elaborates to a primitive application, X arg explicit. + Of type forall X : Set, nat * X + No Printing All: p' r' + Set Printing Projections.: r'.(p') + Printing All: r'.(@p') + *) + +Check p' r'. +Set Printing Projections. +Check p' r'. +Unset Printing Projections. +Set Printing All. +Check p' r'. +Unset Printing All. + +(* Same elaboration, printing for p r *) + +(** Explicit version of the primitive projection, under applied w.r.t implicit arguments + can be printed only using projection notation. r.(@p) *) +Check r'.(@p' _). +Set Printing Projections. +Check r'.(@p' _). +Unset Printing Projections. +Set Printing All. +Check r'.(@p' _). +Unset Printing All. + +(** Explicit version of the primitive projection, applied to its implicit arguments + can be printed only using projection notation r.(p), r.(@p) in fully explicit form *) +Check p' r' nat. +Set Printing Projections. +Check p' r' nat. +Unset Printing Projections. +Set Printing All. +Check p' r' nat. +Unset Printing All. + +Check (@p' nat). +Check p'. +Set Printing All. + +Check (@p' nat). +Check p'. +Unset Printing All. diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v index bf302df4..dbbd57ae 100644 --- a/test-suite/success/proof_using.v +++ b/test-suite/success/proof_using.v @@ -65,3 +65,56 @@ End S1. Check (deep 3 4 : 3 = 4). Check (deep2 3 4 : 3 = 4). + +Section P1. + +Variable x : nat. +Variable y : nat. +Variable z : nat. + + +Collection TOTO := x y. + +Collection TITI := TOTO - x. + +Lemma t1 : True. Proof using TOTO. trivial. Qed. +Lemma t2 : True. Proof using TITI. trivial. Qed. + + Section P2. + Collection TOTO := x. + Lemma t3 : True. Proof using TOTO. trivial. Qed. + End P2. + +Lemma t4 : True. Proof using TOTO. trivial. Qed. + +End P1. + +Lemma t5 : True. Fail Proof using TOTO. trivial. Qed. + +Check (t1 1 2 : True). +Check (t2 1 : True). +Check (t3 1 : True). +Check (t4 1 2 : True). + + +Section T1. + +Variable x : nat. +Hypothesis px : 1 = x. +Let w := x + 1. + +Set Suggest Proof Using. + +Set Default Proof Using "Type". + +Lemma bla : 2 = w. +Proof. +admit. +Qed. + +End T1. + +Check (bla 7 : 2 = 8). + + + diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v index 4d743a6d..1e667884 100644 --- a/test-suite/success/refine.v +++ b/test-suite/success/refine.v @@ -62,14 +62,14 @@ Abort. Goal (forall n : nat, n = 0 -> Prop) -> Prop. intro P. refine (P _ _). -reflexivity. +2:reflexivity. Abort. (* Submitted by Jacek Chrzaszcz (bug #1102) *) -(* le problème a été résolu ici par normalisation des evars présentes - dans les types d'evars, mais le problème reste a priori ouvert dans - le cas plus général d'evars non instanciées dans les types d'autres +(* le problème a été résolu ici par normalisation des evars présentes + dans les types d'evars, mais le problème reste a priori ouvert dans + le cas plus général d'evars non instanciées dans les types d'autres evars *) Goal exists n:nat, n=n. @@ -84,7 +84,7 @@ Definition div : refine (fun m div_rec n => match div_rec m n with - | exist _ _ => _ + | exist _ _ _ => _ end). Abort. diff --git a/test-suite/success/rewrite.v b/test-suite/success/rewrite.v index 08c406be..6dcd6592 100644 --- a/test-suite/success/rewrite.v +++ b/test-suite/success/rewrite.v @@ -129,3 +129,22 @@ intros. Fail rewrite H in H0. Abort. +(* Test subst in the presence of a dependent let-in *) +(* Was not working prior to May 2014 *) + +Goal forall x y, x=y+0 -> let z := x+1 in x+1=y -> z=z -> z=x. +intros. +subst x. (* was failing *) +subst z. +rewrite H0. +auto with arith. +Qed. + +(* Check that evars are instantiated when the term to rewrite is + closed, like in the case it is open *) + +Goal exists x, S 0 = 0 -> S x = 0. +eexists. intro H. +rewrite H. +reflexivity. +Abort. diff --git a/test-suite/success/rewrite_dep.v b/test-suite/success/rewrite_dep.v new file mode 100644 index 00000000..fe250ae8 --- /dev/null +++ b/test-suite/success/rewrite_dep.v @@ -0,0 +1,33 @@ +Require Import Setoid. +Require Import Morphisms. +Require Vector. +Notation vector := Vector.t. +Notation Vcons n t := (@Vector.cons _ n _ t). + +Class Equiv A := equiv : A -> A -> Prop. +Class Setoid A `{Equiv A} := setoid_equiv:> Equivalence (equiv). + +Instance vecequiv A `{Equiv A} n : Equiv (vector A n). +admit. +Qed. + +Global Instance vcons_proper A `{Equiv A} `{!Setoid A} : + Proper (equiv ==> forall_relation (fun k => equiv ==> equiv)) + (@Vector.cons A). +Proof. Admitted. + +Instance vecseotid A `{Setoid A} n : Setoid (vector A n). +Proof. Admitted. + +(* Instance equiv_setoid A {e : Equiv A} {s : @Setoid A e} : Equivalence e. *) +(* apply setoid_equiv. *) +(* Qed. *) +(* Typeclasses Transparent Equiv. *) + +Goal forall A `{Equiv A} `{!Setoid A} (f : A -> A) (a b : A) (H : equiv a b) n (v : vector A n), + equiv (Vcons a v) (Vcons b v). +Proof. + intros. + rewrite H0. + reflexivity. +Qed. \ No newline at end of file diff --git a/test-suite/success/rewrite_strat.v b/test-suite/success/rewrite_strat.v new file mode 100644 index 00000000..04c67556 --- /dev/null +++ b/test-suite/success/rewrite_strat.v @@ -0,0 +1,53 @@ +Require Import Setoid. + +Variable X : Set. + +Variable f : X -> X. +Variable g : X -> X -> X. +Variable h : nat -> X -> X. + +Variable lem0 : forall x, f (f x) = f x. +Variable lem1 : forall x, g x x = f x. +Variable lem2 : forall n x, h (S n) x = g (h n x) (h n x). +Variable lem3 : forall x, h 0 x = x. + +Hint Rewrite lem0 lem1 lem2 lem3 : rew. + +Goal forall x, h 10 x = f x. +Proof. + intros. + Time autorewrite with rew. (* 0.586 *) + reflexivity. +Time Qed. (* 0.53 *) + +Goal forall x, h 6 x = f x. +intros. + Time rewrite_strat topdown lem2. + Time rewrite_strat topdown lem1. + Time rewrite_strat topdown lem0. + Time rewrite_strat topdown lem3. + reflexivity. +Undo 5. + Time rewrite_strat topdown (choice lem2 lem1). + Time rewrite_strat topdown (choice lem0 lem3). + reflexivity. +Undo 3. + Time rewrite_strat (topdown (choice lem2 lem1); topdown (choice lem0 lem3)). + reflexivity. +Undo 2. + Time rewrite_strat (topdown (choice lem2 (choice lem1 (choice lem0 lem3)))). + reflexivity. +Undo 2. + Time rewrite_strat (topdown (choice lem2 (choice lem1 (choice lem0 lem3)))). + reflexivity. +Qed. + +Goal forall x, h 10 x = f x. +Proof. + intros. + Time rewrite_strat topdown (hints rew). (* 0.38 *) + reflexivity. +Time Qed. (* 0.06 s *) + +Set Printing All. +Set Printing Depth 100000. \ No newline at end of file diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v index 653b5bf9..be0d49e0 100644 --- a/test-suite/success/setoid_test.v +++ b/test-suite/success/setoid_test.v @@ -153,7 +153,7 @@ End mult. does not fix the instance at the first unification, use [at], or simply rewrite for this semantics. *) -Require Import Arith. +Parameter beq_nat : forall x y : nat, bool. Class Foo (A : Type) := {foo_neg : A -> A ; foo_prf : forall x : A, x = foo_neg x}. Instance: Foo nat. admit. Defined. diff --git a/test-suite/success/setoid_unif.v b/test-suite/success/setoid_unif.v new file mode 100644 index 00000000..912596b4 --- /dev/null +++ b/test-suite/success/setoid_unif.v @@ -0,0 +1,27 @@ +(* An example of unification in rewrite which uses eager substitution + of metas (provided by Pierre-Marie). + + Put in the test suite as an indication of what the use metas + eagerly flag provides, even though the concrete cases that use it + are seldom. Today supported thanks to a new flag for using evars + eagerly, after this variant of setoid rewrite started to use clause + environments based on evars (fbbe491cfa157da627) *) + +Require Import Setoid. + +Parameter elt : Type. +Parameter T : Type -> Type. +Parameter empty : forall A, T A. +Parameter MapsTo : forall A : Type, elt -> A -> T A -> Prop. + +(* Definition In A x t := exists e, MapsTo A x e t. *) +Axiom In : forall A, A -> T A -> Prop. +Axiom foo : forall A x, In A x (empty A) <-> False. + +Record R := { t : T unit; s : unit }. +Definition Empty := {| t := empty unit; s := tt |}. + +Goal forall x, ~ In _ x (t Empty). +Proof. +intros x. +rewrite foo. diff --git a/test-suite/success/simpl.v b/test-suite/success/simpl.v index 271e6ef7..b5330779 100644 --- a/test-suite/success/simpl.v +++ b/test-suite/success/simpl.v @@ -45,3 +45,55 @@ Goal forall A B (a:A) l f (i:B), fold_right f i ((a :: l))=i. simpl. admit. Qed. (* Qed will fail if simplification is incorrect (de Bruijn!) *) + +(* Check that maximally inserted arguments do not break interpretation + of references in simpl, vm_compute etc. *) + +Arguments fst {A} {B} p. + +Goal fst (0,0) = 0. +simpl fst. +Fail set (fst _). +Abort. + +Goal fst (0,0) = 0. +vm_compute fst. +Fail set (fst _). +Abort. + +Goal let f x := x + 0 in f 0 = 0. +intro. +vm_compute f. +Fail set (f _). +Abort. + +(* This is a change wrt 8.4 (waiting to know if it breaks script a lot or not)*) + +Goal 0+0=0. +Fail simpl @eq. +Abort. + +(* Check reference by notation in simpl *) + +Goal 0+0 = 0. +simpl "+". +Fail set (_ + _). +Abort. + +(* Check occurrences *) + +Record box A := Box { unbox : A }. + +Goal unbox _ (unbox _ (unbox _ (Box _ (Box _ (Box _ True))))) = + unbox _ (unbox _ (unbox _ (Box _ (Box _ (Box _ True))))). +simpl (unbox _ (unbox _ _)) at 1. +match goal with |- True = unbox _ (unbox _ (unbox _ (Box _ (Box _ (Box _ True))))) => idtac end. +Undo 2. +Fail simpl (unbox _ (unbox _ _)) at 5. +simpl (unbox _ (unbox _ _)) at 1 4. +match goal with |- True = unbox _ (Box _ True) => idtac end. +Undo 2. +Fail simpl (unbox _ (unbox _ _)) at 3 4. (* Nested and even overlapping *) +simpl (unbox _ (unbox _ _)) at 2 4. +match goal with |- unbox _ (Box _ True) = unbox _ (Box _ True) => idtac end. +Abort. diff --git a/test-suite/success/somatching.v b/test-suite/success/somatching.v new file mode 100644 index 00000000..5ed833ec --- /dev/null +++ b/test-suite/success/somatching.v @@ -0,0 +1,64 @@ +Goal forall A B C (p : forall (x : A) (y : B), C x y) (x : A) (y : B), True. +Proof. + intros A B C p x y. + match type of p with + | forall x y, @?F x y => pose F as C1 + end. + match type of p with + | forall x y, @?F y x => pose F as C2 + end. + assert (C1 x y) as ?. + assert (C2 y x) as ?. +Abort. + +Goal forall A B C D (p : forall (x : A) (y : B) (z : C), D x y) (x : A) (y : B), True. +Proof. + intros A B C D p x y. + match type of p with + | forall x y z, @?F x y => pose F as C1 + end. + assert (C1 x y) as ?. +Abort. + +Goal forall A B C D (p : forall (z : C) (x : A) (y : B), D x y) (x : A) (y : B), True. +Proof. + intros A B C D p x y. + match type of p with + | forall z x y, @?F x y => pose F as C1 + end. + assert (C1 x y) as ?. +Abort. + +(** Those should fail *) + +Goal forall A B C (p : forall (x : A) (y : B), C x y) (x : A) (y : B), True. +Proof. + intros A B C p x y. + Fail match type of p with + | forall x, @?F x y => pose F as C1 + end. + Fail match type of p with + | forall x y, @?F x x y => pose F as C1 + end. + Fail match type of p with + | forall x y, @?F x => pose F as C1 + end. +Abort. + +(** This one is badly typed *) + +Goal forall A (B : A -> Type) (C : forall x, B x -> Type), (forall x y, C x y) -> True. +Proof. +intros A B C p. +Fail match type of p with +| forall x y, @?F y x => idtac +end. +Abort. + +Goal forall A (B : A -> Type) (C : Type) (D : forall x, B x -> Type), (forall x (z : C) y, D x y) -> True. +Proof. +intros A B C D p. +match type of p with +| forall x z y, @?F x y => idtac +end. +Abort. diff --git a/test-suite/success/unfold.v b/test-suite/success/unfold.v index c067eb81..2954e255 100644 --- a/test-suite/success/unfold.v +++ b/test-suite/success/unfold.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* nat := fun xâ‚ => xâ‚. -Definition π₂ := snd. +Definition π₂ := @snd. (** More unicode in identifiers *) Definition αβ_áà_×ב := 0. +Notation "C 'áµ’áµ–'" := C (at level 30). (** UNICODE IN STRINGS *) diff --git a/test-suite/success/unification.v b/test-suite/success/unification.v index 997dceb4..296686e1 100644 --- a/test-suite/success/unification.v +++ b/test-suite/success/unification.v @@ -1,3 +1,7 @@ +Let test_stack_unification_interaction_with_delta A + : (if negb _ then true else false) = if orb false (negb A) then true else false + := eq_refl. + (* Test patterns unification *) Lemma l1 : (forall P, (exists x:nat, P x) -> False) @@ -97,7 +101,7 @@ apply H. Qed. (* Feature deactivated in commit 14189 (see commit log) -(* Test instanciation of evars by unification *) +(* Test instantiation of evars by unification *) Goal (forall x, 0 + x = 0 -> True) -> True. intros; eapply H. diff --git a/test-suite/success/univscompute.v b/test-suite/success/univscompute.v new file mode 100644 index 00000000..1d60ab36 --- /dev/null +++ b/test-suite/success/univscompute.v @@ -0,0 +1,32 @@ +Set Universe Polymorphism. + +Polymorphic Definition id {A : Type} (a : A) := a. + +Eval vm_compute in id 1. + +Polymorphic Inductive ind (A : Type) := cons : A -> ind A. + +Eval vm_compute in ind unit. + +Check ind unit. + +Eval vm_compute in ind unit. + +Definition bar := Eval vm_compute in ind unit. +Definition bar' := Eval vm_compute in id (cons _ tt). + +Definition bar'' := Eval native_compute in id 1. +Definition bar''' := Eval native_compute in id (cons _ tt). + +Definition barty := Eval native_compute in id (cons _ Set). + +Definition one := @id. + +Monomorphic Definition sec := one. + +Eval native_compute in sec. +Definition sec' := Eval native_compute in sec. +Eval vm_compute in sec. +Definition sec'' := Eval vm_compute in sec. + + diff --git a/test-suite/typeclasses/NewSetoid.v b/test-suite/typeclasses/NewSetoid.v index 58668d03..6f37de65 100644 --- a/test-suite/typeclasses/NewSetoid.v +++ b/test-suite/typeclasses/NewSetoid.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* D -> C nat := fun _ _ => 0. +Instance : A -> D -> C nat := fun _ _ => 0. +Instance : B -> C bool := fun _ => true. + +Instance : forall A, C A -> C (option A) := fun A _ => None. + +Set Typeclasses Debug. + +Set Typeclasses Unique Solutions. +(** This forces typeclass resolution to fail if at least two solutions + exist to a given set of constraints. This is a global setting. + For constraints involving assumed unique instances, it will not fail + if two such instances could apply, however it will fail if two different + instances of a unique class could apply. + *) +Fail Definition foo (d d' : D) (b b' : B) (a' a'' : A) := c : nat. +Definition foo (d d' : D) (b b' : B) (a' : A) := c : nat. + +Fail Definition foo' (b b' : B) := _ : B. +Unset Typeclasses Unique Solutions. +Definition foo' (b b' : B) := _ : B. + +Set Typeclasses Unique Solutions. +Definition foo'' (d d' : D) := _ : D. + +(** Cut backtracking *) +Module BacktrackGreenCut. + Unset Typeclasses Unique Solutions. + Class C (A : Type) := c : A. + + Class D (A : Type) : Type := { c_of_d :> C A }. + + Instance D1 : D unit. + Admitted. + + Instance D2 : D unit. + Admitted. + + (** Two instances of D unit, but when searching for [C unit], no + backtracking on the second instance should be needed except + in dependent cases. Check by adding an unresolvable constraint. + *) + + Variable f : D unit -> C bool -> True. + Fail Definition foo := f _ _. + + Fail Definition foo' := let y := _ : D unit in let x := _ : C bool in f _ x. + + Unset Typeclasses Strict Resolution. + Class Transitive (A : Type) := { trans : True }. + Class PreOrder (A : Type) := { preorder_trans :> Transitive A }. + Class PartialOrder (A : Type) := { partialorder_trans :> Transitive A }. + Class PartialOrder' (A : Type) := { partialorder_trans' :> Transitive A }. + + Instance: PreOrder nat. Admitted. + Instance: PartialOrder nat. Admitted. + + Class NoInst (A : Type) := {}. + + Variable foo : forall `{ T : Transitive nat } `{ NoInst (let x:=@trans _ T in nat) }, nat. + + Fail Definition bar := foo. + + +End BacktrackGreenCut. diff --git a/test-suite/typeclasses/deftwice.v b/test-suite/typeclasses/deftwice.v new file mode 100644 index 00000000..439782c9 --- /dev/null +++ b/test-suite/typeclasses/deftwice.v @@ -0,0 +1,9 @@ +Class C (A : Type) := c : A -> Type. + +Record Inhab (A : Type) := { witness : A }. + +Instance inhab_C : C Type := Inhab. + +Variable full : forall A (X : C A), forall x : A, c x. + +Definition truc {A : Type} : Inhab A := (full _ _ _). \ No newline at end of file diff --git a/test-suite/vio/seff.v b/test-suite/vio/seff.v new file mode 100644 index 00000000..447e7798 --- /dev/null +++ b/test-suite/vio/seff.v @@ -0,0 +1,10 @@ +Inductive equal T (x : T) : T -> Type := Equal : equal T x x. + +Module bla. + +Lemma test n : equal nat n (n + n) -> equal nat (n + n + n) n. +Proof using. +intro H. rewrite <- H. rewrite <- H. exact (Equal nat n). +Qed. + +End bla. diff --git a/test-suite/vio/simple.v b/test-suite/vio/simple.v new file mode 100644 index 00000000..407074c1 --- /dev/null +++ b/test-suite/vio/simple.v @@ -0,0 +1,2 @@ +Lemma simple : True. +Proof using. trivial. Qed. diff --git a/test-suite/vio/univ_constraints_statements.v b/test-suite/vio/univ_constraints_statements.v new file mode 100644 index 00000000..bb6b9595 --- /dev/null +++ b/test-suite/vio/univ_constraints_statements.v @@ -0,0 +1,2 @@ +Lemma ssr_congr_arrow Plemma Pgoal : Plemma = Pgoal -> Plemma -> Pgoal. +Proof using. intro H; rewrite H; trivial. Qed. -- cgit v1.2.3