Skip to main content
8 of 20
[Edit removed during grace period]
Οurous
  • 8.1k
  • 1
  • 16
  • 38

Clean

  • 1 < n <= 23 in 32 seconds on TIO (17 seconds locally)
  • n = 24 (2311294134347173535961967837989) in 25 seconds locally
  • n = 25 (23112941343471735359619678378979) in 134 seconds locally (22 seconds is GC)

This uses a similar approach to Arnauld's JS solution based on recursive permutation rejection, using a specialized tree-set to gain a lot of speed.

For every prime that needs to fit in the number:

  1. check if the prime is a sub-string of another prime, and if so, remove it
  2. sort the current list of prime sub-strings, join it, and add it to the balanced tree set
  3. check if any primes fit on the front of any other ones, and if so, join them

Then, for each pair of sub-strings that we joined, prepend that joined pair to the list of sub-strings and recuse.

Once no more sub-strings can be joined to any other sub-strings on any arm of our recursion, we use the already-ordered tree set to quickly find the lowest number containing the substrings.

I believe that there is still significant optimization to be made in determining which numbers to attempt merges with using this approach, and that that is probably the best avenue for me to pursue
Using Integers instead of Strings (not Ints) may also be a good idea if memory is an issue

module main
import StdEnv,StdOverloadedList,_SystemEnumStrict
import Data.List,Data.Func,Data.Maybe
import Text

// adapted from Data.Set to work with a single specific type, and persist uniqueness
:: *Set a = Tip | Bin !Int !a !*(Set a) !*(Set a)
:: SetPair = {len :: !Int, str :: !String}

delta :== 4
ratio :== 2

:: NumberType :== String

makeSetType e = e//{len=size e,str=e}

:: SetType :== NumberType//= {len :: Int, str :: String}

toNumberType = toString

//uSingleton :: !SetType -> Set
uSingleton x :== (Bin 1 x Tip Tip)

// adapted from Data.Set to work with a single specific type, and persist uniqueness
uFindMin :: !(Set a) -> a
uFindMin (Bin _ x Tip _) = x
uFindMin (Bin _ _ l _)   = uFindMin l

uSize set :== case set of
	Tip = (0, Tip)
	s=:(Bin sz _ _ _) = (sz, s)

uInsertM :: !(a a -> Bool) -> (!a !(Set a) -> *(Bool, Set a))
uInsertM cmp = uInsertM`
where
	uInsertM` x Tip = (False, uSingleton x)
	uInsertM` x set=:(Bin _ y l r)
		| cmp x y//sx < sy || sx == sy && x < y
			# (t, l) = uInsertM` x l
			= (t, uBalanceL y l r)
			//= (t, if(t)(\y` l` r` = Bin sz y` l` r`) uBalanceL y l r)
		| cmp y x//sx > sy || sx == sy && x > y
			# (t, r) = uInsertM` x r
			= (t, uBalanceR y l r)
			//= (t, if(t)(\y` l` r` = Bin sz y` l` r`) uBalanceR y l r)
		| otherwise = (True, set)

// adapted from Data.Set to work with a single specific type, and persist uniqueness
uBalanceL :: !a !(Set a) !(Set a) -> (Set a)
uBalanceL x Tip Tip
	= Bin 1 x Tip Tip
uBalanceL x l=:(Bin _ _ Tip Tip) Tip
	= Bin 2 x l Tip
uBalanceL x l=:(Bin _ lx Tip (Bin _ lrx _ _)) Tip
	= Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)
uBalanceL x l=:(Bin _ lx ll=:(Bin _ _ _ _) Tip) Tip
	= Bin 3 lx ll (Bin 1 x Tip Tip)
uBalanceL x l=:(Bin ls lx ll=:(Bin lls _ _ _) lr=:(Bin lrs lrx lrl lrr)) Tip
	| lrs < ratio*lls
		= Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)
	# (lrls, lrl) = uSize lrl
	# (lrrs, lrr) = uSize lrr
	| otherwise
		= Bin (1+ls) lrx (Bin (1+lls+lrls) lx ll lrl) (Bin (1+lrrs) x lrr Tip)
uBalanceL x Tip r=:(Bin rs _ _ _)
	= Bin (1+rs) x Tip r
uBalanceL x l=:(Bin ls lx ll lr) r=:(Bin rs _ _ _)
	| ls > delta*rs
		= uBalanceL` ll lr
	| otherwise
		= Bin (1+ls+rs) x l r
where
	uBalanceL` ll=:(Bin lls _ _ _) lr=:(Bin lrs lrx lrl lrr)
		| lrs < ratio*lls
			= Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)
		# (lrls, lrl) = uSize lrl
		# (lrrs, lrr) = uSize lrr
		| otherwise
			= Bin (1+ls+rs) lrx (Bin (1+lls+lrls) lx ll lrl) (Bin (1+rs+lrrs) x lrr r)

// adapted from Data.Set to work with a single specific type, and persist uniqueness
uBalanceR :: !a !(Set a) !(Set a) -> Set a
uBalanceR x Tip Tip
	= Bin 1 x Tip Tip
uBalanceR x Tip r=:(Bin _ _ Tip Tip)
	= Bin 2 x Tip r
uBalanceR x Tip r=:(Bin _ rx Tip rr=:(Bin _ _ _ _))
	= Bin 3 rx (Bin 1 x Tip Tip) rr
uBalanceR x Tip r=:(Bin _ rx (Bin _ rlx _ _) Tip)
	= Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)
uBalanceR x Tip r=:(Bin rs rx rl=:(Bin rls rlx rll rlr) rr=:(Bin rrs _ _ _))
	| rls < ratio*rrs
		= Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr
	# (rlls, rll) = uSize rll
	# (rlrs, rlr) = uSize rlr
	| otherwise
		= Bin (1+rs) rlx (Bin (1+rlls) x Tip rll) (Bin (1+rrs+rlrs) rx rlr rr)
uBalanceR x l=:(Bin ls _ _ _) Tip
	= Bin (1+ls) x l Tip
uBalanceR x l=:(Bin ls _ _ _) r=:(Bin rs rx rl rr)
	| rs > delta*ls
		= uBalanceR` rl rr
	| otherwise
		= Bin (1+ls+rs) x l r
where
	uBalanceR` rl=:(Bin rls rlx rll rlr) rr=:(Bin rrs _ _ _)
		| rls < ratio*rrs
			= Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr
		# (rlls, rll) = uSize rll
		# (rlrs, rlr) = uSize rlr
		| otherwise
			= Bin (1+ls+rs) rlx (Bin (1+ls+rlls) x l rll) (Bin (1+rrs+rlrs) rx rlr rr)
			
primes :: [Int]
primes =: [2: [i \\ i <- [3, 5..] | all (\n = i rem n <> 0) (TakeWhile (\n = i >= n*n) primes)]]

primePrefixes :: [[NumberType]]
primePrefixes =: TlM (Scan removeOverlap [] [toNumberType p \\ p <- primes])

removeOverlap subs nsub
	# l = [s \\ s <- subs | size nsub < size s || indexOf s nsub == -1]
	# (a, b) = span ((>)nsub) l
	= a ++ [nsub] ++ b
			
getMergeCandidate :: !NumberType !NumberType -> Maybe NumberType
getMergeCandidate a b
	| a == b = Nothing
	| otherwise
		= last_prefix max_len
where
	sa = size a - 1
	max_len = min sa (size b - 1)
	last_prefix :: !Int -> Maybe String
	last_prefix 0 = Nothing
	last_prefix n
		| b%(0,n-1)== a%(n,sa)
			= Just (a%(0,n-1) + b)
		| otherwise
			= last_prefix (dec n)
			
mergeString :: !NumberType !NumberType -> NumberType
mergeString a b = first_prefix (max (size a - size b) 0)
where
	sa = size a - 1
	first_prefix :: !Int -> String
	first_prefix n
		| b%(0,sa-n) == a%(n,sa)
			= a%(0,n-1) + b
		| otherwise
			= first_prefix (inc n)
			
uFilterSt :: (a -> *s -> (Bool, *s)) -> ([a] *s -> ([a], *s))
uFilterSt fn = uFilterSt`
where
	uFilterSt` [] s = ([], s)
	uFilterSt` [h:t] s
		# (iff, s) = fn h s
		| not iff
			= uFilterSt` t s
		# (t, s) = uFilterSt` t s
		| otherwise
			= ([h:t], s)
	
	
:: CombType :== NumberType
// todo: keep track of merges that we make independent of the resulting whole number
mapCandidatePermsSt :: ![[NumberType]] !*(Set NumberType) -> *(Set NumberType)
mapCandidatePermsSt [ ] returnSet = returnSet
mapCandidatePermsSt [h:t] returnSet
	#! (mem, returnSet) = uInsertM minFinder h` returnSet
	| mem
		= mapCandidatePermsSt t returnSet
	| otherwise
		# merges = [removeOverlap h y \\ x <- h, (Just y) <- Map (getMergeCandidate x) h]
		= mapCandidatePermsSt (merges ++| t) returnSet
where
	h` = foldl mergeString "" h
	dropper e s
		# (mem, s) = uInsertM (<) e s
		= (not mem, s)
	
		
containmentNumbersSt = [ uFindMin (mapCandidatePermsSt [p] Tip) \\ p <- primePrefixes] 

minFinder :== (\a b = let sa = size a; sb = size b in if(sa == sb) (a < b) (sa < sb))

Start = [(i, ' ',n , '\n') \\ i <- [1..] & n <- containmentNumbersSt]

Try it online!

Save to main.icl and compile with:
clm -dynamics -fusion -nci -h 2000m -s 50m -IL Dynamics -IL StdEnv -IL Platform main

If it complains about the heap, make the number after -h bigger, same for -s and the stack.
Additionally, if the program's memory usage hits the maximum heap size while running it will slow down immensely to do a bit of garbage collection - in this case, increase the number after -h.

Οurous
  • 8.1k
  • 1
  • 16
  • 38