-- Copyright (C) 2021-2025 Rudy Matela
-- Distributed under the 3-Clause BSD licence (see the file LICENSE).
import Test
import Conjure.Red
main :: IO ()
main = mainTest tests 5040
tests :: Int -> [Bool]
tests n =
[ True
-- tests of conjureIsDeconstruction --
-- obvious deconstructions
, isDecon (minus :$ i_ :$ one) == True
, isDecon (minus :$ i_ :$ two) == True
, isDecon (div' i_ two) == True
, isDecon (tail' is_) == True
, isDecon (init' is_) == True
, isDecon (drop' one is_) == True
-- obvious constructions
, isDecon (i_ -+- one) == False
, isDecon (i_ -+- two) == False
, isDecon (i_ -*- two) == False
, isDecon (xx -:- is_) == False
, isDecon (is_ -++- unit xx) == False
-- doing nothing is not deconstructing
, isDecon (i_) == False
, isDecon (is_) == False
-- double deconstructions & constructions
, isDecon (minusOne -+- i_) == True
, isDecon (minus :$ (minus :$ i_ :$ one) :$ one) == True
, isDecon (minus :$ i_ :$ three) == True
, isDecon (minus :$ i_ :$ four) == True
, isDecon (minus :$ i_ :$ five) == True
, isDecon (minus :$ i_ :$ six) == True
, isDecon (drop' two is_) == True
, isDecon (drop' three is_) == True
, isDecon (drop' xx is_) == False -- may not deconstruct!
, isDecon (tail' (tail' is_)) == False -- does not deconstruct [1]
, isDecon (init' (init' is_)) == False -- does not deconstruct [1]
, isDecon (init' (tail' is_)) == False -- does not deconstruct [1]
, isDecon (drop' one (drop' one is_)) == True
, isDecon (drop' one (tail' is_)) == True
, isDecon (take' one is_) == False -- does not deconstruct [1]
, isDecon (take' two is_) == False -- does not deconstruct [1,1]
-- counter-intuitive but true: x `mod` y is a deconstruction of y:
-- x `mod` y < y for y > 0
, isDecon (mod' xx i_) == True
, isDecon (mod' i_ two) == False -- does not deconstruct 1
, isDecon (mod' i_ xx) == False -- may not deconstruct 1
, isDecon (div' xx yy) == False -- must have a hole to indicate the value being deconstructed
, isDecon (div' i_ i_) == False -- two holes are not allowed
, isDecon (head' is_) == False -- must deconstruct to the same type
-- constant "deconstructions"
, isDecon (const' zero i_) == False -- always mapping to size 0 is not allowed!
, isDecon (const' nil is_) == False -- always mapping to size 0 is not allowed!
, isDecon (const' one i_) == False -- does not deconstruct 1
-- negative "deconstructions"
, isDecon (minus :$ zero :$ i_) == False
, isDecon (minus :$ one :$ i_) == False
-- boolean "deconstructions"
, isDecon (not' b_) == False -- always mapping to size 0 is not allowed!
, isDecon (false -||- b_) == False -- always mapping to size 0 is not allowed!
, candidateDeconstructionsFrom (div' xx yy) == [ div' i_ yy
, div' xx i_
]
, candidateDeconstructionsFrom (div' xx xx) == []
, candidateDeconstructionsFrom ((xx -+- xx) -+- yy) == [(xx -+- xx) -+- i_]
, candidateDeconstructionsFromHoled (div' i_ i_) == [ div' i_ xx
, div' xx i_
]
, candidateDeconstructionsFromHoled (div' xx yy) == []
, candidateDeconstructionsFromHoled ((i_ -+- i_) -+- i_) ==
[ (i_ -+- xx) -+- yy
, (i_ -+- xx) -+- xx
, (xx -+- i_) -+- yy
, (xx -+- i_) -+- xx
, (xx -+- yy) -+- i_
, (xx -+- xx) -+- i_
]
-- simple integer descent
, descends isDecOf (ff xx) (ff xx) == False
, descends isDecOf (ff xx) (ff (xx -+- one)) == False
, descends isDecOf (ff xx) (ff (dec xx)) == True
, descends isDecOf (ff xx) (ff (yy `mod'` xx)) == True
-- simple list descent
, descends isDecOf (ff xxs) (ff xxs) == False
, descends isDecOf (ff xxs) (ff (tail' xxs)) == True
, descends isDecOf (ff (xx -:- xxs)) (ff xxs) == True
, descends isDecOf (ff xxs) (ff (xxs -++- xxs)) == False
-- double integer descent
, descends isDecOf (ff2 xx yy) (ff2 xx yy) == False
, descends isDecOf (ff2 xx yy) (ff2 (xx -+- one) yy) == False
, descends isDecOf (ff2 xx yy) (ff2 (dec xx) yy) == True
, descends isDecOf (ff2 xx yy) (ff2 (dec yy) xx) == True
, descends isDecOf (ff2 xx yy) (ff2 xx (dec yy)) == True
, descends isDecOf (ff2 xx yy) (ff2 yy (dec xx)) == True
, descends isDecOf (ff2 xx yy) (ff2 (dec xx) (dec yy)) == True
, descends isDecOf (ff2 xx yy) (ff2 (dec yy) (dec xx)) == True
-- double list descent
, descends isDecOf (xxs -++- yys) (xxs -++- yys) == False
, descends isDecOf (xxs -++- yys) (xxs -++- tail' yys) == True
, descends isDecOf (xxs -++- yys) (tail' yys -++- yys) == False
, descends isDecOf (xxs -++- yys) ((xx -:- xxs) -++- tail' yys) == True
, descends isDecOf (xxs -++- yys) (head' xxs -:- tail' xxs -++- head' yys -:- tail' yys) == False
-- gcd descent
, descends isDecOf (ff2 xx yy) (ff2 yy (xx `mod'` yy)) == True -- actual gcd descent
, descends isDecOf (ff2 xx yy) (ff2 yy (yy `mod'` yy)) == True -- other
-- interleave descent
, descends isDecOf (xxs -\/- yys) (yys -\/- tail' xxs) == True
, descends isDecOf (xxs -\/- yys) (tail' yys -\/- xxs) == True
, descends isDecOf (xxs -\/- yys) (tail' yys -\/- tail' xxs) == True
, descends isDecOf ((xx -:- xxs) -\/- yys) (yys -\/- xxs) == True
, descends isDecOf (xxs -\/- (yy -:- yys)) (yys -\/- xxs) == True
, descends isDecOf ((xx -:- xxs) -\/- (yy -:- yys)) (yys -\/- xxs) == True
-- disallowed descents
, descends isDecOf ((xx -:- xxs) -?- (yy -:- yys)) (yys -?- (xx -:- yys)) == False
, descends isDecOf ((xx -:- xxs) -?- (yy -:- yys)) (yys -?- (yy -:- yys)) == False
]
isDecOf :: Expr -> Expr -> Bool
e1 `isDecOf` e2 = any ((e1 -|- e2) `isInstanceOf`)
[ tail' xxs -|- xxs
, dec xx -|- xx
, yy `mod'` xx -|- xx
]
(-\/-) :: Expr -> Expr -> Expr
exs -\/- eys = interleaveE :$ exs :$ eys
where
interleaveE = value "\\/" ((\/) :: [Int] -> [Int] -> [Int])
[] \/ ys = ys
(x:xs) \/ ys = x : (ys \/ xs)
isDecon :: Expr -> Bool
isDecon = conjureIsDeconstruction (undefined :: [Int] -> [Char] -> [Bool]) 60
dec :: Expr -> Expr
dec ex = minus :$ ex :$ one