#!/usr/local/bin/maple
#-*- maplev -*-

# Nathaniel Shar
# HW 18
# Experimental Mathematics

# It is okay to link to this assignment on the course webpage.

Help := proc(): print(`AllWords(A, n), IsBad1(w, fp1, B), IsBad(w, FP, B), SetWnS(A, FP, B, n), WnS(A,FP,B,n), SFP(d,n), IsBadBeginning1(w, fp1, B), IsBadBeginning(w, FP, B), SetWGnS(A, FP, B, n, BFP), WGnS(A, FP, B, n, BFP)`): end:

#############
# Problem 1 #
#############

# Inaccuracy #1: It does not take a "select few" to make art out of
# mathematics. Anyone can do it with access to the proper tools and
# some dedication.

# Inaccuracy #2: Combinatorics is much broader than the "science of
# number sequences." In addition, "number sequences" are not the same
# as "arithmetical [sic] progressions."

# Inaccuracy #3: Arithmetic progressions of arbitrary length can be
# found in any sequence of integers of positive density, not any
# "positive sequence".

# Inaccuracy #4: The problem of Professor Littman is not completely
# described. Also, it is kind of amusing that we are supposed to be
# impressed by the "reference to the 18th-century Swiss mathematician
# Leonhard Euler." That's the mathematical equivalent of a reference
# to that obscure 16th-century English playwright, William Shakespeare.


#############
# Problem 2 #
#############

AllWords := proc(A, n) local w, i: option remember:
    if n = 1 then:
        return {seq([i], i in A)}:
    else:
        return {seq(seq([op(w), i], i in A), w in AllWords(A, n-1))}:
    fi:
end:

IsBad1 := proc(w, fp1, B) local i, v: option remember:
    if fp1 = [] then:
        return true:
    elif w = [] then:
        return false:
    elif w[1] = fp1[1] or fp1[1] = B then:
        if nops(fp1) <= nops(w) then:
            v := true:
            for i from 2 to nops(fp1) do:
                if fp1[i] <> w[i] and fp1[i] <> B then:
                    v := false:
                fi:
            od:
            if v = true then:
                return v:
            fi:
        fi:
    fi:
    return IsBad1(w[2..nops(w)], fp1, B):
end:

IsBad := proc(w, FP, B) local p:
    for p in FP do:
        if IsBad1(w, p, B) then:
            return true:
        fi:
    od:
    return false:
end:

SetWnS := proc(A, FP, B, n) local w, S:
    S := {}:
    for w in AllWords(A, n) do:
        if not IsBad(w, FP, B) then:
            S := S union {w}:
        fi:
    od:
    return S:
end:



WnS := proc(A,FP,B,n):
    return nops(SetWnS(A, FP, B, n)):
end:

#############
# Problem 3 #
#############

# Part 1:

# 2, 4, 7, 13, 23, 40, 65, 106, 169, 278, 443, 705, 1117, 1760, 2807

# Part 2:

#  2, 4, 6, 10, 14, 20, 16, 6, 0, 0, 0, 0, 0, 0, 0

# Meaning: Every 2-coloring of [9] has a monochromatic arithmetic
# progression of length 3.


#############
# Problem 4 #
#############

SFP := proc(d,n) local i, FP:
    if d = 1 then:
        return [1]:
    fi:
    FP := {}:
    for i from 0 to floor((n-d)/(d-1)) do:
        FP := FP union [(1, B$i)$(d-1), 1]:
    od:
    return FP:
end:

#############
# Problem 6 #
#############

IsBadBeginning1 := proc(w, fp1, B) option remember:
    if fp1 = [] then:
        return true:
    elif w = [] then:
        return false:
    elif fp1[1] = B or fp[1] = w[1] then:
        return IsBadBeginning1(w[2..nops(w)], fp1[2..nops(fp1)], B)
    else:
        return false:
    fi:
end:

IsBadBeginning := proc(w, FP, B) local p:
    for p in FP do:
        if IsBadBeginning1(w, p, B) then:
            return true:
        fi:
    od:
    return false:
end:

SetWGnS := proc(A, FP, B, n, BFP) local S, w, p:
    S := {}:
    for w in SetWnS(A, FP, B, n) do:
        if not IsBadBeginning(w, BFP) then:
            S := S union {w}:
        fi:
    od:
    return S:
end:

WGnS := proc(A, FP, B, n, BFP):
    return nops(SetWGnS(A, FP, B, n, BFP)):
end: