TESTS: vector find tests

TESTS: vector find tests

Red [
	Title:   "Red series test script"
	Author:  "Peter W A Wood"
	File: 	 %vector-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/red/red/blob/origin/BSD-3-License.txt"
]

#include  %../../../quick-test/quick-test.red

~~~start-file~~~ "vector"

===start-group=== "make"

	vector-make-test: func [
		name [string!]
		type [datatype!]
		spec [block!]
		len [integer!]
		test-value [char! float! integer!]
		/local
			vm-v
	][
		--test-- name
		vm-v: make vector! spec
		--assert len = length? vm-v
		foreach v vm-v [
			test-value: test-value + 1
			--assert test-value = v
			--assert type = type? v
		]
		--assert none = vm-v/0
		--assert none = vm-v/(len + 1)
	]

	--test-- "vector-make-1"
		vm1-v: make vector! 10
		--assert 10 = length? vm1-v
		foreach v vm1-v [
			--assert v = 0
			--assert integer! = type? v
		]
		--assert none = vm1-v/0
		--assert none = vm1-v/11

	vector-make-test "vector-make-2" integer! [1 2 3 4 5] 5 0

	vector-make-test "vector-make-3" char! [#"b" #"c" #"d" #"e"] 4 #"a"

	vector-make-test "vector-make-4" float! [1.0 2.0 3.0 4.0 5.0] 5 0.0

	vector-make-test "vector-make-5" integer! [integer! 8 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-6" integer! [integer! 16 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-7" integer! [integer! 32 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-8" float! [float! 64 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

	vector-make-test "vector-make-9" float! [float! 32 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

===end-group===

===start-group=== "vector-truncate"

	--test-- "vector-trunc-1"
		vt1-v: make vector! [char! 8 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt1-v #"^(0100)"
		--assert 4 = length? vt1-v
		--assert #"^(00)" = vt1-v/4
		--assert none = vt1-v/5

	--test-- "vector-trunc-2"
		vt2-v: make vector! [char! 16 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt2-v #"^(100100)"
		--assert 4 = length? vt2-v
		--assert #"^(0100)" = vt2-v/4
		--assert none = vt2-v/5

	--test-- "vector-trunc-3"
		vt3-v: make vector! [integer! 8 [0 1 2]]
		append vt3-v 256
		--assert 4 = length? vt3-v
		--assert 0 = vt3-v/4
		--assert none = vt3-v/5

	--test-- "vector-trunc-4"
		vt4-v: make vector! [integer! 16 [0 1 2]]
		append vt4-v 65536
		--assert 4 = length? vt4-v
		--assert 0 = vt4-v/4
		--assert none = vt4-v/5

	--test-- "vector-trunc-6"
		vt5-v: make vector! [float! 32 [0.0 1.0 2.0]]
		append vt5-v 1.23456789012345678901234567
		--assert 1.2345679 = round/to vt5-v/4 0.0000001

===end-group===

===start-group=== "vector path notation"

	--test-- "vector-path-1"
		vp1-v: [0 1 2 3 4]
		--assert none = vp1-v/0
		--assert 0 = vp1-v/1
		--assert 1 = vp1-v/2
		--assert 2 = vp1-v/3
		--assert 3 = vp1-v/4
		--assert 4 = vp1-v/5
		--assert none = vp1-v/6
		--assert none = vp1-v/-1

===end-group===

===start-group=== "vector navigation"

	--test-- "vector-navigation-1"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next vn-v
		--assert vn-v/1 = 1
		--assert vn-v/4 = 4

	--test-- "vector-navigation-2"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next next vn-v
		--assert vn-v/1 = 2
		--assert vn-v/3 = 4

	--test-- "vector-navigation-3"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next next next vn-v
		--assert vn-v/1 = 3
		--assert vn-v/2 = 4

	--test-- "vector-navigation-4"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next next next next vn-v
		--assert vn-v/1 = 4

	--test-- "vector-navigation-5"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: tail vn-v
		--assert vn-v/1 = none

	--test-- "vector-navigation-6"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: back tail vn-v
		--assert vn-v/1 = 4

	--test-- "vector-navigation-7"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: head tail vn-v
		--assert vn-v/1 = 0
		--assert vn-v/5 = 4

===end-group===

===start-group=== "vector comparison"

	--test-- "vector-comparison-1"
		--assert (make vector! [1 2 3 4]) = make vector! [1 2 3 4]

	--test-- "vector-comparison-2"
		--assert (make vector! [1 2 3 4]) <> make vector! [1 2 3 3]

	--test-- "vector-comparison-3"
		--assert (make vector! [1 2 3 4]) > make vector! [1 2 3 3]

	--test-- "vector-comparison-4"
		--assert (make vector! [1 2 3 3]) < make vector! [1 2 3 4]

	--test-- "vector-comparison-5"
		--assert (make vector! [1 2 3]) < make vector! [1 2 3 4]

	--test-- "vector-comparison-6"
		--assert equal? make vector! [1 2 3 4] make vector! [1 2 3 4]

	--test-- "vector-comparison-7"
		--assert not equal? make vector! [1 2 3 4]make vector! [1 2 3 3]

	--test-- "vector-comparison-8"
		--assert greater? make vector! [1 2 3 4] make vector! [1 2 3 3]

	--test-- "vector-comparison-9"
		--assert lesser? make vector! [1 2 3 3] make vector! [1 2 3 4]

	--test-- "vector-comparison-10"
		--assert lesser? make vector! [1 2 3] make vector! [1 2 3 4]

===end-group===

===start-group=== "vector ordinal"

	--test-- "vector-ordinal-1"
		--assert 1 = first make vector! [1 2 3 4]

	--test-- "vector-ordinal-2"
		--assert 2 = second make vector! [1 2 3 4]

	--test-- "vector-ordinal-3"
		--assert 3 = third make vector! [1 2 3 4]

	--test-- "vector-ordinal-4"
		--assert 4 = fourth make vector! [1 2 3 4]

	--test-- "vector-ordinal-5"
		--assert 5 = fifth make vector! [1 2 3 4 5]

	--test-- "vector-ordinal-6"
		--assert none = fifth make vector! [1 2 3 4]

	--test-- "vector-ordinal-7"
		--assert 4 = last make vector! [1 2 3 4]

	--test-- "vector-ordinal-8"
		--assert 2 = first next make vector! [1 2 3 4]

	--test-- "vector-ordinal-7"
		--assert 3 = second next make vector! [1 2 3 4]

===end-group===

===start-group=== "vector-clear"

		empty-vector: make vector! []

	--test-- "vector-clear-1"
		--assert empty-vector = clear make vector! [1 2 3 4]

	--test-- "vector-clear-2"
		vc2-v: make vector! [1 2 3 4]
		append vc2-v 5
		--assert empty-vector = clear vc2-v

===end-group===

===start-group=== "vector-copy"

	--test-- "vector-copy-1"
		vcp1-v1: make vector! [1 2 3 4]
		vcp1-v2: copy vcp1-v1
		vcp1-v1/1: 5
		vcp1-v1/2: 6
		vcp1-v1/3: 7
		vcp1-v1/4: 8
		--assert vcp1-v1 = make vector! [5 6 7 8]
		--assert vcp1-v2 = make vector! [1 2 3 4]

	--test-- "vector-copy-2"
		vcp2-v: make vector! [1 2 3 4 5 6 7 8 9]
			--assert (make vector! [1 2 3 4]) = copy/part vcp2-v 4

	--test-- "vector-copy-3"
		vcp3-v: make vector! [1 2 3 4 5 6 7 8 9]
			--assert (make vector! [3 4]) = copy/part next next vcp3-v 2

	--test-- "vector-copy-4"
		vcp4-v: make vector! [1 2 3 4 5 6 7 8 9]
			--assert (make vector! [8]) = copy/part back back tail vcp4-v 1

	--test-- "vector-copy-5"
		vcp5-v: make vector! [1 2]
			--assert (make vector! [1 2]) = copy/part vcp5-v 4

===end-group===

===start-group=== "vector poke"

	--test-- "vector-poke-1"
		vp1-v: make vector! [1 2]
		poke vp1-v 1 0
		--assert (make vector! [0 2]) = vp1-v

	--test-- "vector-poke-2"
		vp2-v: make vector! [1 2 3]
		poke vp2-v 3 0
		--assert (make vector! [1 2 0]) = vp2-v

	--test-- "vector-poke-3"
		vp3-v: make vector! [1 2 3]
		poke vp3-v 2 0
		--assert (make vector! [1 0 3]) = vp3-v

===end-group===

===start-group=== "vector remove"

	--test-- "vector-remove-1"
		--assert (make vector! [2 3]) = remove make vector! [1 2 3]

	--test-- "vector-remove-2"
		--assert (make vector! [3]) = remove next make vector! [1 2 3]

	--test-- "vector-remove-3"
		--assert (make vector! []) = remove tail make vector! [1 2 3]

	--test-- "vector-remove-4"
		--assert (make vector! []) = remove back tail make vector! [1 2 3]

	--test-- "vector-remove-5"
		--assert (make vector! [3]) = remove back back tail make vector! [1 2 3]

===end-group===

===start-group=== "vector reverse"

	--test-- "vector-reverse-1"
		--assert (make vector! [4 3 2 1]) = reverse make vector! [1 2 3 4]

	--test-- "vector-reverse-2"
		--assert (make vector! [1 4 3 2 ]) = head reverse next make vector! [1 2 3 4]

	--test-- "vector-reverse-2"
		--assert (make vector! [1 2 3 4]) = head reverse tail make vector! [1 2 3 4]

===end-group===

===start-group=== "vector take"

	--test-- "vector-take-1"
		vt1-v: make vector! [1 2 3 4]
		--assert 1 = take vt1-v
		--assert vt1-v = make vector! [2 3 4]

	--test-- "vector-take-2"
		vt2-v: make vector! [1 2 3 4]
		--assert 2 = take next vt2-v
		--assert vt2-v = make vector! [1 3 4]

	--test-- "vector-take-3"
		vt3-v: make vector! [1 2 3 4]
		--assert 4 = take/last vt3-v
		--assert vt3-v = make vector! [1 2 3]

	--test-- "vector-take-4"
		vt4-v: make vector! [1 2 3 4]
		--assert (make vector! [1 2]) = take/part vt4-v 2
		--assert vt4-v = make vector! [3 4]

	--test-- "vector-take-5"
		vt5-v: make vector! [1 2 3 4]
		--assert (make vector! [1 2]) = take/part vt5-v find vt5-v 3
		--assert vt5-v = make vector! [3 4]

===end-group===

===start-group=== "vector sort"

	--test-- "vector-sort-1"
		--assert (make vector! [1 2 3]) = sort make vector! [3 2 1]

	--test-- "vector-sort-2"
		--assert (make vector! [3 1 2]) = head sort next make vector! [3 2 1]

	--test-- "vector-sort-3"
		--assert (make vector! [3 2 1]) = head sort tail make vector! [3 2 1]

	--test-- "vector-sort-4"
		--assert (make vector! [#"c" #"à" #"é"]) = sort make vector! [#"é" #"à" #"c"]

===end-group===

===start-group=== "vector find"

	--test-- "vector-find-1"
		--assert none = find make vector! [1 2 3 4] "five"

	--test-- "vector-find-2"
		--assert none = find next make vector! [1 2 3 4] 1

	--test-- "vector-find-3"
		--assert 1 = first find make vector! [1 2 3 4] 1

	--test-- "vector-find-4"
		--assert none = find make vector! [1 2 3 4] 1.0

	--test-- "vector-find-5"
		--assert 1 = length? find make vector! [1 2 3 4] 4

	--test-- "vector-find-6"
		--assert none = find/part make vector! [1 2 3 4] 4 3

	--test-- "vector-find-7"
		--assert 3 = first find/part make vector! [1 2 3 4] 3 3
		--assert 4 = second find/part make vector! [1 2 3 4] 3 3
		--assert 2 = length? find/part make vector! [1 2 3 4] 3 3

	--test-- "vector-find-8"
		--assert #"a" = first find/case make vector! [ #"A" #"a" #"b" #"c"] #"a"
		--assert 3 = length? find/case make vector! [ #"A" #"a" #"b" #"c"] #"a"

	--test-- "vector-find-9"
		--assert #"a" = first find make vector! [ #"A" #"a" #"b" #"c"] #"a"

	--test-- "vector-find-10"
		--assert (make vector! [4 5 6]) = find/skip make vector! [1 4 4 4 5 6] 4 3

	--test-- "vector-find-11"
		--assert (make vector! [1]) = find/last make vector! [1 1 1 1 1] 1

	--test-- "vector-find-12"
		vf12-v: next next next make vector! [1 2 1 2 1 2]
		--assert (make vector! [2 1 2 1 2]) = find/reverse vf12-v 2

	--test-- "vector-find-13"
		--assert (make vector! [5 6]) = find/tail make vector! [1 2 3 4 5 6] 4

	--test-- "vector-find-14"
		--assert (make vector! [3 4]) = find/match next make vector! [1 2 3 4] 2

===end-group===

~~~end-file~~~

Red [
	Title:   "Red series test script"
	Author:  "Peter W A Wood"
	File: 	 %vector-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/red/red/blob/origin/BSD-3-License.txt"
]

#include  %../../../quick-test/quick-test.red

~~~start-file~~~ "vector"

===start-group=== "make"

	vector-make-test: func [
		name [string!]
		type [datatype!]
		spec [block!]
		len [integer!]
		test-value [char! float! integer!]
		/local
			vm-v
	][
		--test-- name
		vm-v: make vector! spec
		--assert len = length? vm-v
		foreach v vm-v [
			test-value: test-value + 1
			--assert test-value = v
			--assert type = type? v
		]
		--assert none = vm-v/0
		--assert none = vm-v/(len + 1)
	]

	--test-- "vector-make-1"
		vm1-v: make vector! 10
		--assert 10 = length? vm1-v
		foreach v vm1-v [
			--assert v = 0
			--assert integer! = type? v
		]
		--assert none = vm1-v/0
		--assert none = vm1-v/11

	vector-make-test "vector-make-2" integer! [1 2 3 4 5] 5 0

	vector-make-test "vector-make-3" char! [#"b" #"c" #"d" #"e"] 4 #"a"

	vector-make-test "vector-make-4" float! [1.0 2.0 3.0 4.0 5.0] 5 0.0

	vector-make-test "vector-make-5" integer! [integer! 8 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-6" integer! [integer! 16 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-7" integer! [integer! 32 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-8" float! [float! 64 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

	vector-make-test "vector-make-9" float! [float! 32 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

===end-group===

===start-group=== "vector-truncate"

	--test-- "vector-trunc-1"
		vt1-v: make vector! [char! 8 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt1-v #"^(0100)"
		--assert 4 = length? vt1-v
		--assert #"^(00)" = vt1-v/4
		--assert none = vt1-v/5

	--test-- "vector-trunc-2"
		vt2-v: make vector! [char! 16 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt2-v #"^(100100)"
		--assert 4 = length? vt2-v
		--assert #"^(0100)" = vt2-v/4
		--assert none = vt2-v/5

	--test-- "vector-trunc-3"
		vt3-v: make vector! [integer! 8 [0 1 2]]
		append vt3-v 256
		--assert 4 = length? vt3-v
		--assert 0 = vt3-v/4
		--assert none = vt3-v/5

	--test-- "vector-trunc-4"
		vt4-v: make vector! [integer! 16 [0 1 2]]
		append vt4-v 65536
		--assert 4 = length? vt4-v
		--assert 0 = vt4-v/4
		--assert none = vt4-v/5

	--test-- "vector-trunc-6"
		vt5-v: make vector! [float! 32 [0.0 1.0 2.0]]
		append vt5-v 1.23456789012345678901234567
		--assert 1.2345679 = round/to vt5-v/4 0.0000001

===end-group===

===start-group=== "vector path notation"

	--test-- "vector-path-1"
		vp1-v: [0 1 2 3 4]
		--assert none = vp1-v/0
		--assert 0 = vp1-v/1
		--assert 1 = vp1-v/2
		--assert 2 = vp1-v/3
		--assert 3 = vp1-v/4
		--assert 4 = vp1-v/5
		--assert none = vp1-v/6
		--assert none = vp1-v/-1

===end-group===

===start-group=== "vector navigation"

	--test-- "vector-navigation-1"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next vn-v
		--assert vn-v/1 = 1
		--assert vn-v/4 = 4

	--test-- "vector-navigation-2"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next next vn-v
		--assert vn-v/1 = 2
		--assert vn-v/3 = 4

	--test-- "vector-navigation-3"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next next next vn-v
		--assert vn-v/1 = 3
		--assert vn-v/2 = 4

	--test-- "vector-navigation-4"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: next next next next vn-v
		--assert vn-v/1 = 4

	--test-- "vector-navigation-5"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: tail vn-v
		--assert vn-v/1 = none

	--test-- "vector-navigation-6"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: back tail vn-v
		--assert vn-v/1 = 4

	--test-- "vector-navigation-7"
		vn-v: make vector! [0 1 2 3 4]
		vn-v: head tail vn-v
		--assert vn-v/1 = 0
		--assert vn-v/5 = 4

===end-group===

===start-group=== "vector comparison"

	--test-- "vector-comparison-1"
		--assert (make vector! [1 2 3 4]) = make vector! [1 2 3 4]

	--test-- "vector-comparison-2"
		--assert (make vector! [1 2 3 4]) <> make vector! [1 2 3 3]

	--test-- "vector-comparison-3"
		--assert (make vector! [1 2 3 4]) > make vector! [1 2 3 3]

	--test-- "vector-comparison-4"
		--assert (make vector! [1 2 3 3]) < make vector! [1 2 3 4]

	--test-- "vector-comparison-5"
		--assert (make vector! [1 2 3]) < make vector! [1 2 3 4]

	--test-- "vector-comparison-6"
		--assert equal? make vector! [1 2 3 4] make vector! [1 2 3 4]

	--test-- "vector-comparison-7"
		--assert not equal? make vector! [1 2 3 4]make vector! [1 2 3 3]

	--test-- "vector-comparison-8"
		--assert greater? make vector! [1 2 3 4] make vector! [1 2 3 3]

	--test-- "vector-comparison-9"
		--assert lesser? make vector! [1 2 3 3] make vector! [1 2 3 4]

	--test-- "vector-comparison-10"
		--assert lesser? make vector! [1 2 3] make vector! [1 2 3 4]

===end-group===

===start-group=== "vector ordinal"

	--test-- "vector-ordinal-1"
		--assert 1 = first make vector! [1 2 3 4]

	--test-- "vector-ordinal-2"
		--assert 2 = second make vector! [1 2 3 4]

	--test-- "vector-ordinal-3"
		--assert 3 = third make vector! [1 2 3 4]

	--test-- "vector-ordinal-4"
		--assert 4 = fourth make vector! [1 2 3 4]

	--test-- "vector-ordinal-5"
		--assert 5 = fifth make vector! [1 2 3 4 5]

	--test-- "vector-ordinal-6"
		--assert none = fifth make vector! [1 2 3 4]

	--test-- "vector-ordinal-7"
		--assert 4 = last make vector! [1 2 3 4]

	--test-- "vector-ordinal-8"
		--assert 2 = first next make vector! [1 2 3 4]

	--test-- "vector-ordinal-7"
		--assert 3 = second next make vector! [1 2 3 4]

===end-group===

===start-group=== "vector-clear"

		empty-vector: make vector! []

	--test-- "vector-clear-1"
		--assert empty-vector = clear make vector! [1 2 3 4]

	--test-- "vector-clear-2"
		vc2-v: make vector! [1 2 3 4]
		append vc2-v 5
		--assert empty-vector = clear vc2-v

===end-group===

===start-group=== "vector-copy"

	--test-- "vector-copy-1"
		vcp1-v1: make vector! [1 2 3 4]
		vcp1-v2: copy vcp1-v1
		vcp1-v1/1: 5
		vcp1-v1/2: 6
		vcp1-v1/3: 7
		vcp1-v1/4: 8
		--assert vcp1-v1 = make vector! [5 6 7 8]
		--assert vcp1-v2 = make vector! [1 2 3 4]

	--test-- "vector-copy-2"
		vcp2-v: make vector! [1 2 3 4 5 6 7 8 9]
			--assert (make vector! [1 2 3 4]) = copy/part vcp2-v 4

	--test-- "vector-copy-3"
		vcp3-v: make vector! [1 2 3 4 5 6 7 8 9]
			--assert (make vector! [3 4]) = copy/part next next vcp3-v 2

	--test-- "vector-copy-4"
		vcp4-v: make vector! [1 2 3 4 5 6 7 8 9]
			--assert (make vector! [8]) = copy/part back back tail vcp4-v 1

	--test-- "vector-copy-5"
		vcp5-v: make vector! [1 2]
			--assert (make vector! [1 2]) = copy/part vcp5-v 4

===end-group===

===start-group=== "vector poke"

	--test-- "vector-poke-1"
		vp1-v: make vector! [1 2]
		poke vp1-v 1 0
		--assert (make vector! [0 2]) = vp1-v

	--test-- "vector-poke-2"
		vp2-v: make vector! [1 2 3]
		poke vp2-v 3 0
		--assert (make vector! [1 2 0]) = vp2-v

	--test-- "vector-poke-3"
		vp3-v: make vector! [1 2 3]
		poke vp3-v 2 0
		--assert (make vector! [1 0 3]) = vp3-v

===end-group===

===start-group=== "vector remove"

	--test-- "vector-remove-1"
		--assert (make vector! [2 3]) = remove make vector! [1 2 3]

	--test-- "vector-remove-2"
		--assert (make vector! [3]) = remove next make vector! [1 2 3]

	--test-- "vector-remove-3"
		--assert (make vector! []) = remove tail make vector! [1 2 3]

	--test-- "vector-remove-4"
		--assert (make vector! []) = remove back tail make vector! [1 2 3]

	--test-- "vector-remove-5"
		--assert (make vector! [3]) = remove back back tail make vector! [1 2 3]

===end-group===

===start-group=== "vector reverse"

	--test-- "vector-reverse-1"
		--assert (make vector! [4 3 2 1]) = reverse make vector! [1 2 3 4]

	--test-- "vector-reverse-2"
		--assert (make vector! [1 4 3 2 ]) = head reverse next make vector! [1 2 3 4]

	--test-- "vector-reverse-2"
		--assert (make vector! [1 2 3 4]) = head reverse tail make vector! [1 2 3 4]

===end-group===

===start-group=== "vector take"

	--test-- "vector-take-1"
		vt1-v: make vector! [1 2 3 4]
		--assert 1 = take vt1-v
		--assert vt1-v = make vector! [2 3 4]

	--test-- "vector-take-2"
		vt2-v: make vector! [1 2 3 4]
		--assert 2 = take next vt2-v
		--assert vt2-v = make vector! [1 3 4]

	--test-- "vector-take-3"
		vt3-v: make vector! [1 2 3 4]
		--assert 4 = take/last vt3-v
		--assert vt3-v = make vector! [1 2 3]

	--test-- "vector-take-4"
		vt4-v: make vector! [1 2 3 4]
		--assert (make vector! [1 2]) = take/part vt4-v 2
		--assert vt4-v = make vector! [3 4]

	--test-- "vector-take-5"
		vt5-v: make vector! [1 2 3 4]
		--assert (make vector! [1 2]) = take/part vt5-v find vt5-v 3
		--assert vt5-v = make vector! [3 4]

===end-group===

===start-group=== "vector sort"

	--test-- "vector-sort-1"
		--assert (make vector! [1 2 3]) = sort make vector! [3 2 1]

	--test-- "vector-sort-2"
		--assert (make vector! [3 1 2]) = head sort next make vector! [3 2 1]

	--test-- "vector-sort-3"
		--assert (make vector! [3 2 1]) = head sort tail make vector! [3 2 1]

	--test-- "vector-sort-4"
		--assert (make vector! [#"c" #"à" #"é"]) = sort make vector! [#"é" #"à" #"c"]

===end-group===

~~~end-file~~~


FIX: missing debug messages for verbose mode.

Red/System [
	Title:   "Float! datatype runtime functions"
	Author:  "Nenad Rakocevic, Oldes"
	File: 	 %decimal.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

#define DBL_EPSILON		2.2204460492503131E-16

float: context [
	verbose: 4

	uint64!: alias struct! [int1 [byte-ptr!] int2 [byte-ptr!]]
	int64!:  alias struct! [int1 [integer!] int2 [integer!]]

	DOUBLE_MAX: 0.0
	+INF: 0.0											;-- rebol can't load INF, NaN
	QNaN: 0.0

	double-int-union: as int64! :DOUBLE_MAX				;-- set to largest number
	double-int-union/int2: 7FEFFFFFh
	double-int-union/int1: FFFFFFFFh

	double-int-union: as int64! :+INF
	double-int-union/int2: 7FF00000h

	double-int-union: as int64! :QNaN					;-- smallest quiet NaN
	double-int-union/int2: 7FF80000h

	abs: func [
		value	[float!]
		return: [float!]
		/local
			n	[int-ptr!]
	][
		n: (as int-ptr! :value) + 1
		n/value: n/value and 7FFFFFFFh
		value
	]

	get*: func [										;-- unboxing float value from stack
		return: [float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		assert TYPE_OF(fl) = TYPE_FLOAT
		fl/value
	]

	get-any*: func [									;-- special get* variant for SWITCH
		return: [float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		either TYPE_OF(fl) = TYPE_FLOAT [fl/value][0.0] ;-- accept NONE values
	]

	get: func [											;-- unboxing float value
		value	[red-value!]
		return: [float!]
		/local
			fl [red-float!]
	][
		assert TYPE_OF(value) = TYPE_FLOAT
		fl: as red-float! value
		fl/value
	]

	box: func [
		value	[float!]
		return: [red-float!]
		/local
			int [red-float!]
	][
		fl: as red-float! stack/arguments
		fl/header: TYPE_FLOAT
		fl/value: value
		fl
	]

	to-integer: func [
		number 	[float!]
		return:	[integer!]
		/local
			f	[float!]
			d	[int-ptr!]
	][
		;-- Based on this method: http://stackoverflow.com/a/429812/494472
		;-- A bit more explanation: http://lolengine.net/blog/2011/3/20/understanding-fast-float-integer-conversions
		f: number + 6755399441055744.0
		d: as int-ptr! :f
		d/value
	]

	form-float: func [
		f 		[float!]
		return: [c-string!]
		/local
			s	[c-string!]
			s0	[c-string!]
			p0	[c-string!]
			p	[c-string!]
			p1	[c-string!]
			dot? [logic!]
			d	[int64!]
			w0	[integer!]
	][
		d: as int64! :f
		w0: d/int2												;@@ Use little endian. Watch out big endian !

		if w0 and 7FF00000h = 7FF00000h [
			if all [
				zero? d/int1									;@@ Use little endian. Watch out big endian !
				zero? (w0 and 000FFFFFh)
			][
				return either 0 = (w0 and 80000000h) ["1.#INF"]["-1.#INF"]
			]
			return "1.#NaN"
		]

		s: "0000000000000000000000000000000"					;-- 32 bytes wide, big enough.
		sprintf [s "%.14g" f]

		dot?: no
		p:  null
		p1: null
		s0: s
		until [
			if s/1 = #"." [dot?: yes]
			if s/1 = #"e" [
				p: s
				until [
					s: s + 1
					s/1 > #"0"
				]
				p1: s
			]
			s: s + 1
			s/1 = #"^@"
		]

		if p1 <> null [											;-- remove #"+" and leading zero
			p0: p
			either p/2 = #"-" [p: p + 2][p: p + 1]
			move-memory as byte-ptr! p as byte-ptr! p1 as-integer s - p1
			s: p + as-integer s - p1
			s/1: #"^@"
			p: p0
		]
		unless dot? [											;-- added tailing ".0"
			either p = null [
				p: s
			][
				move-memory as byte-ptr! p + 2 as byte-ptr! p as-integer s - p
			]
			p/1: #"."
			p/2: #"0"
			s/3: #"^@"
		]
		s0
	]

	do-math: func [
		type	  [integer!]
		return:	  [red-float!]
		/local
			left  [red-float!]
			right [red-float!]
			int   [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/do-math"]]

		left:  as red-float! stack/arguments
		right: as red-float! left + 1

		assert any [									;@@ replace by typeset check when possible
			TYPE_OF(left) = TYPE_INTEGER
			TYPE_OF(left) = TYPE_FLOAT
		]
		assert any [
			TYPE_OF(right) = TYPE_INTEGER
			TYPE_OF(right) = TYPE_CHAR
			TYPE_OF(right) = TYPE_FLOAT
		]

		if TYPE_OF(left) <> TYPE_FLOAT [
			int: as red-integer! left
			left/header: TYPE_FLOAT
			left/value: integer/to-float int/value
		]
		if TYPE_OF(right) <> TYPE_FLOAT [
			int: as red-integer! right
			right/value: integer/to-float int/value
		]

		left/value: switch type [
			OP_ADD [left/value + right/value]
			OP_SUB [left/value - right/value]
			OP_MUL [left/value * right/value]
			OP_DIV [left/value / right/value]
			OP_REM [left/value % right/value]
			default [print-line "*** Math Error: float don't support BITWISE OP!" left/value]
		]
		left
	]

	load-in: func [
		blk	  	[red-block!]
		value 	[float!]
		/local
			fl [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/load-in"]]

		fl: as red-float! ALLOC_TAIL(blk)
		fl/header: TYPE_FLOAT
		fl/value: value
	]

	push64: func [
		high	[integer!]
		low		[integer!]
		return: [red-float!]
		/local
			cell [cell!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/push64"]]

		cell: stack/push*
		cell/header: TYPE_FLOAT
		cell/data2: low
		cell/data3: high
		as red-float! cell
	]

	push: func [
		value	[float!]
		return: [red-float!]
		/local
			fl [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/push"]]

		fl: as red-float! stack/push*
		fl/header: TYPE_FLOAT
		fl/value: value
		fl
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/make"]]

		switch TYPE_OF(spec) [
			TYPE_FLOAT [
				as red-float! spec
			]
			default [
				--NOT_IMPLEMENTED--
				as red-float! spec					;@@ just for making it compilable
			]
		]
	]

	random: func [
		f		[red-float!]
		seed?	[logic!]
		secure? [logic!]
		only?   [logic!]
		return: [red-float!]
		/local
			t	[float!]
			s	[float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/random"]]

		either seed? [
			_random/srand to-integer f/value
			f/header: TYPE_UNSET
		][
			s: (integer/to-float _random/rand) / 2147483647.0
			if s < 0.0 [s: 0.0 - s]
			f/value: s * f/value
		]
		f
	]

	to: func [
		type	[red-datatype!]
		spec	[red-float!]
		return: [red-value!]
		/local
			int [red-integer!]
			buf [red-string!]
			f	[float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "to/random"]]

		f: spec/value
		switch type/value [
			TYPE_INTEGER [
				int: as red-integer! type
				int/header: TYPE_INTEGER
				int/value: to-integer either f < 0.0 [f + 0.499999999999999][f - 0.499999999999999]
			]
			TYPE_STRING [
				buf: string/rs-make-at as cell! type 1			;-- 16 bits string
				string/concatenate-literal buf form-float f
			]
			default [
				print-line "** Script error: Invalid argument for TO float!"
				type/header: TYPE_UNSET
			]
		]
		as red-value! type
	]

	form: func [
		fl		   [red-float!]
		buffer	   [red-string!]
		arg		   [red-value!]
		part 	   [integer!]
		return:    [integer!]
		/local
			formed [c-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/form"]]

		formed: form-float fl/value
		string/concatenate-literal buffer formed
		part - length? formed							;@@ optimize by removing length?
	]

	mold: func [
		fl		[red-float!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part 	[integer!]
		indent	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/mold"]]

		form fl buffer arg part
	]

	NaN?: func [
		value	[float!]
		return: [logic!]
		/local
			n	[int-ptr!]
			m	[int-ptr!]
	][
		m: as int-ptr! :value
		n: m + 1
		either n/value and 7FF00000h = 7FF00000h [		;-- the exponent bits are all ones
			either any [								;-- the fraction bits are not entirely zeros
				m/value <> 0
				n/value and 000FFFFFh <> 0
			] [true][false]
		][false]
	]

	;@@ using 64bit integer will simplify it significantly.
	;-- returns false if either number is (or both are) NAN.
	;-- treats really large numbers as almost equal to infinity.
	;-- thinks +0.0 and -0.0 are 0 DLP's apart.
	;-- Max ULP: 4 (enough for ordinary use)
	;-- Ref: https://github.com/svn2github/googletest/blob/master/include/gtest/internal/gtest-internal.h
	;--      https://github.com/rebol/rebol/blob/master/src/core/t-decimal.c
	almost-equal: func [
		left	[float!]
		right	[float!]
		return: [logic!]
		/local
			a	 [uint64!]
			b	 [uint64!]
			lo1  [byte-ptr!]
			lo2  [byte-ptr!]
			hi1  [byte-ptr!]
			hi2  [byte-ptr!]
			diff [byte-ptr!]
	][
		if left = right [return true]					;-- for NaN, also raise error in default mode
		if any [NaN? left NaN? right] [return false]

		a: as uint64! :left
		b: as uint64! :right
		lo1: a/int1
		lo2: b/int1
		hi1: a/int2
		hi2: b/int2

		either (as-integer hi1) < 0 [
			hi1: as byte-ptr! (not as-integer hi1)
			lo1: as byte-ptr! (not as-integer lo1)
			either (as-integer lo1) = -1 [hi1: hi1 + 1 lo1: null][lo1: lo1 + 1]
		][
			hi1: as byte-ptr! (as-integer hi1) or 80000000h
		]

		either (as-integer hi2) < 0 [
			hi2: as byte-ptr! (not as-integer hi2)
			lo2: as byte-ptr! (not as-integer lo2)
			either (as-integer lo2) = -1 [hi2: hi2 + 1 lo2: null][lo2: lo2 + 1]
		][
			hi2: as byte-ptr! (as-integer hi2) or 80000000h
		]

		diff: either hi1 > hi2 [hi1 - hi2][hi2 - hi1]
		if diff > (as byte-ptr! 1) [return false]

		case [
			hi1 = hi2 [
				diff: either lo1 < lo2 [lo2 - lo1][lo1 - lo2]
			]
			hi1 > hi2 [
				either lo1 >= lo2 [return false][
					diff: (as byte-ptr! -1) - lo2 + lo1 + 1
				]
			]
			hi2 > hi1 [
				either lo2 >= lo1 [return false][
					diff: (as byte-ptr! -1) - lo1 + lo2 + 1
				]
			]
		]

		diff <= (as byte-ptr! 4)
	]

	compare: func [
		value1    [red-float!]						;-- first operand
		value2    [red-float!]						;-- second operand
		op	      [integer!]						;-- type of comparison
		return:   [logic!]
		/local
			int   [red-integer!]
			left  [float!]
			right [float!]
			res	  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/compare"]]

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_CHAR
			TYPE_INTEGER [
				int: as red-integer! value2
				right: integer/to-float int/value
			]
			TYPE_FLOAT [right: value2/value]
			default [RETURN_COMPARE_OTHER]
		]
		switch op [
			COMP_EQUAL 			[res: almost-equal left right]
			COMP_NOT_EQUAL 		[res: not almost-equal left right]
			COMP_STRICT_EQUAL	[res: all [TYPE_OF(value2) = TYPE_FLOAT left = right]]
			COMP_LESSER			[res: left <  right]
			COMP_LESSER_EQUAL	[res: left <= right]
			COMP_GREATER		[res: left >  right]
			COMP_GREATER_EQUAL	[res: left >= right]
		]
		res
	]

	complement: func [
		fl		[red-float!]
		return:	[red-value!]
	][
		--NOT_IMPLEMENTED--
		;fl/value: not fl/value
		as red-value! fl
	]

	absolute: func [
		return: [red-float!]
		/local
			f	  [red-float!]
			value [float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/absolute"]]

		f: as red-float! stack/arguments
		f/value: abs f/value
		f 											;-- re-use argument slot for return value
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/subtract"]]
		as red-value! do-math OP_SUB
	]

	remainder: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/remainder"]]
		as red-value! do-math OP_REM
	]

	negate: func [
		return: [red-float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		fl/value: 0.0 - fl/value
		fl 											;-- re-use argument slot for return value
	]

	power: func [
		return:	 [red-float!]
		/local
			base [red-float!]
			exp  [red-float!]
			int	 [red-integer!]
	][
		base: as red-float! stack/arguments
		exp: base + 1
		if TYPE_OF(exp) = TYPE_INTEGER [
			int: as red-integer! exp
			exp/value: integer/to-float int/value
		]
		base/value: float-power base/value exp/value
		base
	]

	even?: func [
		int		[red-float!]
		return: [logic!]
	][
		;requires conversion to integer
		;not as-logic float/value and 1
		--NOT_IMPLEMENTED--
		false
	]

	odd?: func [
		int		[red-integer!]
		return: [logic!]
	][
		;requires conversion to integer
		;as-logic int/value and 1
		--NOT_IMPLEMENTED--
		false
	]

	#define FLOAT_TRUNC(x) [d: floor float/abs x either x < 0.0 [0.0 - d][d]]
	#define FLOAT_AWAY(x)  [d: ceil float/abs x  either x < 0.0 [0.0 - d][d]]

	round: func [
		value		[red-value!]
		scale		[red-float!]
		_even?		[logic!]
		down?		[logic!]
		half-down?	[logic!]
		floor?		[logic!]
		ceil?		[logic!]
		half-ceil?	[logic!]
		return:		[red-value!]
		/local
			int		[red-integer!]
			f		[red-float!]
			dec		[float!]
			sc		[float!]
			r		[float!]
			d		[float!]
			e		[integer!]
			v		[logic!]
	][
		e: 0
		f: as red-float! value
		dec: f/value
		sc: 1.0
		if OPTION?(scale) [
			if TYPE_OF(scale) = TYPE_INTEGER [
				int: as red-integer! value
				int/value: to-integer dec
				int/header: TYPE_INTEGER
				return integer/round value as red-integer! scale _even? down? half-down? floor? ceil? half-ceil?
			]
			sc: abs scale/value
		]

		if sc = 0.0 [
			print-line "*** Math Error: float overflow on ROUND"
			value/header: TYPE_UNSET
			return value
		]

		if sc < ldexp abs dec -53 [return value]		;-- is scale negligible?

		v: sc >= 1.0
		dec: either v [dec / sc][
			r: frexp sc :e
			either e <= -1022 [
				sc: r
				dec: ldexp dec e
			][e: 0]
			sc: 1.0 / sc
			dec * sc
		]

		d: abs dec
		r: 0.5 + floor d
		dec: case [
			down?		[FLOAT_TRUNC(dec)]
			floor?		[floor dec		 ]
			ceil?		[ceil dec		 ]
			r < d		[FLOAT_AWAY(dec) ]
			r > d		[FLOAT_TRUNC(dec)]
			_even?		[either d % 2.0 < 1.0 [FLOAT_TRUNC(dec)][FLOAT_AWAY(dec)]]
			half-down?	[FLOAT_TRUNC(dec)]
			half-ceil?	[ceil dec		 ]
			true		[FLOAT_AWAY(dec) ]
		]

		f/value: either v [
			dec: dec * sc
			if DOUBLE_MAX = abs dec [
				print-line "*** Math Error: float overflow on ROUND"
				value/header: TYPE_UNSET
			]
			dec
		][
			ldexp dec / sc e
		]
		value
	]

	init: does [
		datatype/register [
			TYPE_FLOAT
			TYPE_VALUE
			"float!"
			;-- General actions --
			:make
			:random
			null			;reflect
			:to
			:form
			:mold
			null			;eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			:absolute
			:add
			:divide
			:multiply
			:negate
			:power
			:remainder
			:round
			:subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			null			;copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]

Red/System [
	Title:   "Float! datatype runtime functions"
	Author:  "Nenad Rakocevic, Oldes"
	File: 	 %decimal.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

#define DBL_EPSILON		2.2204460492503131E-16

float: context [
	verbose: 4

	uint64!: alias struct! [int1 [byte-ptr!] int2 [byte-ptr!]]
	int64!:  alias struct! [int1 [integer!] int2 [integer!]]

	DOUBLE_MAX: 0.0
	+INF: 0.0											;-- rebol can't load INF, NaN
	QNaN: 0.0

	double-int-union: as int64! :DOUBLE_MAX				;-- set to largest number
	double-int-union/int2: 7FEFFFFFh
	double-int-union/int1: FFFFFFFFh

	double-int-union: as int64! :+INF
	double-int-union/int2: 7FF00000h

	double-int-union: as int64! :QNaN					;-- smallest quiet NaN
	double-int-union/int2: 7FF80000h

	abs: func [
		value	[float!]
		return: [float!]
		/local
			n	[int-ptr!]
	][
		n: (as int-ptr! :value) + 1
		n/value: n/value and 7FFFFFFFh
		value
	]

	get*: func [										;-- unboxing float value from stack
		return: [float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		assert TYPE_OF(fl) = TYPE_FLOAT
		fl/value
	]

	get-any*: func [									;-- special get* variant for SWITCH
		return: [float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		either TYPE_OF(fl) = TYPE_FLOAT [fl/value][0.0] ;-- accept NONE values
	]

	get: func [											;-- unboxing float value
		value	[red-value!]
		return: [float!]
		/local
			fl [red-float!]
	][
		assert TYPE_OF(value) = TYPE_FLOAT
		fl: as red-float! value
		fl/value
	]

	box: func [
		value	[float!]
		return: [red-float!]
		/local
			int [red-float!]
	][
		fl: as red-float! stack/arguments
		fl/header: TYPE_FLOAT
		fl/value: value
		fl
	]

	to-integer: func [
		number 	[float!]
		return:	[integer!]
		/local
			f	[float!]
			d	[int-ptr!]
	][
		;-- Based on this method: http://stackoverflow.com/a/429812/494472
		;-- A bit more explanation: http://lolengine.net/blog/2011/3/20/understanding-fast-float-integer-conversions
		f: number + 6755399441055744.0
		d: as int-ptr! :f
		d/value
	]

	form-float: func [
		f 		[float!]
		return: [c-string!]
		/local
			s	[c-string!]
			s0	[c-string!]
			p0	[c-string!]
			p	[c-string!]
			p1	[c-string!]
			dot? [logic!]
			d	[int64!]
			w0	[integer!]
	][
		d: as int64! :f
		w0: d/int2												;@@ Use little endian. Watch out big endian !

		if w0 and 7FF00000h = 7FF00000h [
			if all [
				zero? d/int1									;@@ Use little endian. Watch out big endian !
				zero? (w0 and 000FFFFFh)
			][
				return either 0 = (w0 and 80000000h) ["1.#INF"]["-1.#INF"]
			]
			return "1.#NaN"
		]

		s: "0000000000000000000000000000000"					;-- 32 bytes wide, big enough.
		sprintf [s "%.14g" f]

		dot?: no
		p:  null
		p1: null
		s0: s
		until [
			if s/1 = #"." [dot?: yes]
			if s/1 = #"e" [
				p: s
				until [
					s: s + 1
					s/1 > #"0"
				]
				p1: s
			]
			s: s + 1
			s/1 = #"^@"
		]

		if p1 <> null [											;-- remove #"+" and leading zero
			p0: p
			either p/2 = #"-" [p: p + 2][p: p + 1]
			move-memory as byte-ptr! p as byte-ptr! p1 as-integer s - p1
			s: p + as-integer s - p1
			s/1: #"^@"
			p: p0
		]
		unless dot? [											;-- added tailing ".0"
			either p = null [
				p: s
			][
				move-memory as byte-ptr! p + 2 as byte-ptr! p as-integer s - p
			]
			p/1: #"."
			p/2: #"0"
			s/3: #"^@"
		]
		s0
	]

	do-math: func [
		type	  [integer!]
		return:	  [red-float!]
		/local
			left  [red-float!]
			right [red-float!]
			int   [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/do-math"]]

		left:  as red-float! stack/arguments
		right: as red-float! left + 1

		assert any [									;@@ replace by typeset check when possible
			TYPE_OF(left) = TYPE_INTEGER
			TYPE_OF(left) = TYPE_FLOAT
		]
		assert any [
			TYPE_OF(right) = TYPE_INTEGER
			TYPE_OF(right) = TYPE_CHAR
			TYPE_OF(right) = TYPE_FLOAT
		]

		if TYPE_OF(left) <> TYPE_FLOAT [
			int: as red-integer! left
			left/header: TYPE_FLOAT
			left/value: integer/to-float int/value
		]
		if TYPE_OF(right) <> TYPE_FLOAT [
			int: as red-integer! right
			right/value: integer/to-float int/value
		]

		left/value: switch type [
			OP_ADD [left/value + right/value]
			OP_SUB [left/value - right/value]
			OP_MUL [left/value * right/value]
			OP_DIV [left/value / right/value]
			OP_REM [left/value % right/value]
			default [print-line "*** Math Error: float don't support BITWISE OP!" left/value]
		]
		left
	]

	load-in: func [
		blk	  	[red-block!]
		value 	[float!]
		/local
			fl [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/load-in"]]

		fl: as red-float! ALLOC_TAIL(blk)
		fl/header: TYPE_FLOAT
		fl/value: value
	]

	push64: func [
		high	[integer!]
		low		[integer!]
		return: [red-float!]
		/local
			cell [cell!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/push64"]]

		cell: stack/push*
		cell/header: TYPE_FLOAT
		cell/data2: low
		cell/data3: high
		as red-float! cell
	]

	push: func [
		value	[float!]
		return: [red-float!]
		/local
			fl [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/push"]]

		fl: as red-float! stack/push*
		fl/header: TYPE_FLOAT
		fl/value: value
		fl
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/make"]]

		switch TYPE_OF(spec) [
			TYPE_FLOAT [
				as red-float! spec
			]
			default [
				--NOT_IMPLEMENTED--
				as red-float! spec					;@@ just for making it compilable
			]
		]
	]

	random: func [
		f		[red-float!]
		seed?	[logic!]
		secure? [logic!]
		only?   [logic!]
		return: [red-float!]
		/local
			t	[float!]
			s	[float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/random"]]

		either seed? [
			_random/srand to-integer f/value
			f/header: TYPE_UNSET
		][
			s: (integer/to-float _random/rand) / 2147483647.0
			if s < 0.0 [s: 0.0 - s]
			f/value: s * f/value
		]
		f
	]

	to: func [
		type	[red-datatype!]
		spec	[red-float!]
		return: [red-value!]
		/local
			int [red-integer!]
			buf [red-string!]
			f	[float!]
	][
		f: spec/value
		switch type/value [
			TYPE_INTEGER [
				int: as red-integer! type
				int/header: TYPE_INTEGER
				int/value: to-integer either f < 0.0 [f + 0.499999999999999][f - 0.499999999999999]
			]
			TYPE_STRING [
				buf: string/rs-make-at as cell! type 1			;-- 16 bits string
				string/concatenate-literal buf form-float f
			]
			default [
				print-line "** Script error: Invalid argument for TO float!"
				type/header: TYPE_UNSET
			]
		]
		as red-value! type
	]

	form: func [
		fl		   [red-float!]
		buffer	   [red-string!]
		arg		   [red-value!]
		part 	   [integer!]
		return:    [integer!]
		/local
			formed [c-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/form"]]

		formed: form-float fl/value
		string/concatenate-literal buffer formed
		part - length? formed							;@@ optimize by removing length?
	]

	mold: func [
		fl		[red-float!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part 	[integer!]
		indent	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/mold"]]

		form fl buffer arg part
	]

	NaN?: func [
		value	[float!]
		return: [logic!]
		/local
			n	[int-ptr!]
			m	[int-ptr!]
	][
		m: as int-ptr! :value
		n: m + 1
		either n/value and 7FF00000h = 7FF00000h [		;-- the exponent bits are all ones
			either any [								;-- the fraction bits are not entirely zeros
				m/value <> 0
				n/value and 000FFFFFh <> 0
			] [true][false]
		][false]
	]

	;@@ using 64bit integer will simplify it significantly.
	;-- returns false if either number is (or both are) NAN.
	;-- treats really large numbers as almost equal to infinity.
	;-- thinks +0.0 and -0.0 are 0 DLP's apart.
	;-- Max ULP: 4 (enough for ordinary use)
	;-- Ref: https://github.com/svn2github/googletest/blob/master/include/gtest/internal/gtest-internal.h
	;--      https://github.com/rebol/rebol/blob/master/src/core/t-decimal.c
	almost-equal: func [
		left	[float!]
		right	[float!]
		return: [logic!]
		/local
			a	 [uint64!]
			b	 [uint64!]
			lo1  [byte-ptr!]
			lo2  [byte-ptr!]
			hi1  [byte-ptr!]
			hi2  [byte-ptr!]
			diff [byte-ptr!]
	][
		if left = right [return true]					;-- for NaN, also raise error in default mode
		if any [NaN? left NaN? right] [return false]

		a: as uint64! :left
		b: as uint64! :right
		lo1: a/int1
		lo2: b/int1
		hi1: a/int2
		hi2: b/int2

		either (as-integer hi1) < 0 [
			hi1: as byte-ptr! (not as-integer hi1)
			lo1: as byte-ptr! (not as-integer lo1)
			either (as-integer lo1) = -1 [hi1: hi1 + 1 lo1: null][lo1: lo1 + 1]
		][
			hi1: as byte-ptr! (as-integer hi1) or 80000000h
		]

		either (as-integer hi2) < 0 [
			hi2: as byte-ptr! (not as-integer hi2)
			lo2: as byte-ptr! (not as-integer lo2)
			either (as-integer lo2) = -1 [hi2: hi2 + 1 lo2: null][lo2: lo2 + 1]
		][
			hi2: as byte-ptr! (as-integer hi2) or 80000000h
		]

		diff: either hi1 > hi2 [hi1 - hi2][hi2 - hi1]
		if diff > (as byte-ptr! 1) [return false]

		case [
			hi1 = hi2 [
				diff: either lo1 < lo2 [lo2 - lo1][lo1 - lo2]
			]
			hi1 > hi2 [
				either lo1 >= lo2 [return false][
					diff: (as byte-ptr! -1) - lo2 + lo1 + 1
				]
			]
			hi2 > hi1 [
				either lo2 >= lo1 [return false][
					diff: (as byte-ptr! -1) - lo1 + lo2 + 1
				]
			]
		]

		diff <= (as byte-ptr! 4)
	]

	compare: func [
		value1    [red-float!]						;-- first operand
		value2    [red-float!]						;-- second operand
		op	      [integer!]						;-- type of comparison
		return:   [logic!]
		/local
			int   [red-integer!]
			left  [float!]
			right [float!]
			res	  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/compare"]]

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_CHAR
			TYPE_INTEGER [
				int: as red-integer! value2
				right: integer/to-float int/value
			]
			TYPE_FLOAT [right: value2/value]
			default [RETURN_COMPARE_OTHER]
		]
		switch op [
			COMP_EQUAL 			[res: almost-equal left right]
			COMP_NOT_EQUAL 		[res: not almost-equal left right]
			COMP_STRICT_EQUAL	[res: all [TYPE_OF(value2) = TYPE_FLOAT left = right]]
			COMP_LESSER			[res: left <  right]
			COMP_LESSER_EQUAL	[res: left <= right]
			COMP_GREATER		[res: left >  right]
			COMP_GREATER_EQUAL	[res: left >= right]
		]
		res
	]

	complement: func [
		fl		[red-float!]
		return:	[red-value!]
	][
		--NOT_IMPLEMENTED--
		;fl/value: not fl/value
		as red-value! fl
	]

	absolute: func [
		return: [red-float!]
		/local
			f	  [red-float!]
			value [float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "float/absolute"]]

		f: as red-float! stack/arguments
		f/value: abs f/value
		f 											;-- re-use argument slot for return value
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/subtract"]]
		as red-value! do-math OP_SUB
	]

	remainder: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "float/remainder"]]
		as red-value! do-math OP_REM
	]

	negate: func [
		return: [red-float!]
		/local
			fl [red-float!]
	][
		fl: as red-float! stack/arguments
		fl/value: 0.0 - fl/value
		fl 											;-- re-use argument slot for return value
	]

	power: func [
		return:	 [red-float!]
		/local
			base [red-float!]
			exp  [red-float!]
			int	 [red-integer!]
	][
		base: as red-float! stack/arguments
		exp: base + 1
		if TYPE_OF(exp) = TYPE_INTEGER [
			int: as red-integer! exp
			exp/value: integer/to-float int/value
		]
		base/value: float-power base/value exp/value
		base
	]

	even?: func [
		int		[red-float!]
		return: [logic!]
	][
		;requires conversion to integer
		;not as-logic float/value and 1
		--NOT_IMPLEMENTED--
		false
	]

	odd?: func [
		int		[red-integer!]
		return: [logic!]
	][
		;requires conversion to integer
		;as-logic int/value and 1
		--NOT_IMPLEMENTED--
		false
	]

	#define FLOAT_TRUNC(x) [d: floor float/abs x either x < 0.0 [0.0 - d][d]]
	#define FLOAT_AWAY(x)  [d: ceil float/abs x  either x < 0.0 [0.0 - d][d]]

	round: func [
		value		[red-value!]
		scale		[red-float!]
		_even?		[logic!]
		down?		[logic!]
		half-down?	[logic!]
		floor?		[logic!]
		ceil?		[logic!]
		half-ceil?	[logic!]
		return:		[red-value!]
		/local
			int		[red-integer!]
			f		[red-float!]
			dec		[float!]
			sc		[float!]
			r		[float!]
			d		[float!]
			e		[integer!]
			v		[logic!]
	][
		e: 0
		f: as red-float! value
		dec: f/value
		sc: 1.0
		if OPTION?(scale) [
			if TYPE_OF(scale) = TYPE_INTEGER [
				int: as red-integer! value
				int/value: to-integer dec
				int/header: TYPE_INTEGER
				return integer/round value as red-integer! scale _even? down? half-down? floor? ceil? half-ceil?
			]
			sc: abs scale/value
		]

		if sc = 0.0 [
			print-line "*** Math Error: float overflow on ROUND"
			value/header: TYPE_UNSET
			return value
		]

		if sc < ldexp abs dec -53 [return value]		;-- is scale negligible?

		v: sc >= 1.0
		dec: either v [dec / sc][
			r: frexp sc :e
			either e <= -1022 [
				sc: r
				dec: ldexp dec e
			][e: 0]
			sc: 1.0 / sc
			dec * sc
		]

		d: abs dec
		r: 0.5 + floor d
		dec: case [
			down?		[FLOAT_TRUNC(dec)]
			floor?		[floor dec		 ]
			ceil?		[ceil dec		 ]
			r < d		[FLOAT_AWAY(dec) ]
			r > d		[FLOAT_TRUNC(dec)]
			_even?		[either d % 2.0 < 1.0 [FLOAT_TRUNC(dec)][FLOAT_AWAY(dec)]]
			half-down?	[FLOAT_TRUNC(dec)]
			half-ceil?	[ceil dec		 ]
			true		[FLOAT_AWAY(dec) ]
		]

		f/value: either v [
			dec: dec * sc
			if DOUBLE_MAX = abs dec [
				print-line "*** Math Error: float overflow on ROUND"
				value/header: TYPE_UNSET
			]
			dec
		][
			ldexp dec / sc e
		]
		value
	]

	init: does [
		datatype/register [
			TYPE_FLOAT
			TYPE_VALUE
			"float!"
			;-- General actions --
			:make
			:random
			null			;reflect
			:to
			:form
			:mold
			null			;eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			:absolute
			:add
			:divide
			:multiply
			:negate
			:power
			:remainder
			:round
			:subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			null			;copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]


completed some conditions

completed some conditions

created a version of lessq that compares quotients as well (seems
bizarre that Reduce does not have in-built functionality for that), and
filled in a number of most common conditions. Not fully test yet - will
do it before the next update.

% This is not Rubi and Garnet is not as valuable as Ruby... but at least
% both are basically red...

lisp;
on backtrace, echo, comp; % set some useful (I hope) options

% The existing "rubi_red" package provides a way to access all the
% Rubi rules... But in fact I will set up my own short list...

% load_package rubi_red;

fluid '(rubi_rules);

% To start with I will have just ONE rule!

% (a + b*x^n)^p
% where n*(p+1)=-1
% eg let me try n=1, p=-2, so I get
% (a + b*x^1)^(-2)

rubi_rules := '(

(!/!;
   (!:!=
      (!Int
         (expt (plus (!_ a) (times (!_!. b) (expt (!_ x) (!_ n)))) (!_ p))
         (!_ x !Symbol))
      (quotient (times x (expt (plus a (times b (expt x n))) (plus p 1))) a))
   (and
      (!Free!Q (bracelist a b n p) x)
      (!Zero!Q (plus (times n (plus p 1)) 1))))

)$

algebraic operator unsimplified_int;

symbolic procedure simpgarnet u;
  begin
    scalar a, x, r;
    if length u neq 2 then rederr "garnet requires two arguments";
    a := car u;
    x := cadr u;
    if posn() neq 0 then terpri();
    princ "Integrate "; prin a; princ " wrt "; print x;
% The arguments arrive here are totally unprocessed, and so for instance
% if you write "w := <something>; var := x; garnet(w, var);" what you
% receive will be "w" and "var" not sensible values. I have special code
% to deal with this!
    a := garnet!-simp a;
    x := garnet!-simp x;
    r := garnet_integrate(a, x);
% I hand back a list of length 2 - the first item is the result that
% garnet generates, the second is what the existing old Reduce integrator
% makes of the example.
    return simp list('list, r, list('int, a, x));
  end;

put('garnet, 'simpfn, 'simpgarnet);

% This takes a formula and "evaluates" it by evaluating all the variables
% present in it while trying to preserve the structure around the, So if you
% hand it (x-1)^10 where x has some messy value it will return the expression
% (<messy-value> - 1)^10 rather than multiplying things out. Just in case
% the varibles used had previously been simplified in a way that expanded
% them this does some factorization to try to return things to a "neat"
% form. If substituting values for variables would introduce cases of
% (expression + 0) or (expression^1) it does some minor tidying up to
% make things seem nicer.

symbolic procedure garnet!-simp u;
  if numberp u then u
  else if atom u then garnet!-simpatom u
  else begin
    scalar w;
    w := for each v in cdr u collect garnet!-simp v;
    if car u = 'plus then return garnet!-simp!-plus w
    else if car u = 'difference then return garnet!-simp!-difference w
    else if car u = 'times then return garnet!-simp!-times w
    else if car u = 'quotient then return garnet!-simp!-quotient w
    else if car u = 'expt then return garnet!-simp!-expt w
    else if car u = 'minus then return garnet!-simp!-minus w
    else return car u . w
  end;

% Following might be redundant - commented out for the moment

%symbolic procedure garnet!-simp!-plus l;
%  begin
%    scalar r;
%    for each x in l do if not zerop x then r := x . r;
%    if null r then return 0
%    else if nuill cdr r then return car r
%    else return 'plus . reverse r
%  end;

% The next few reconstruct prefix forms performing only the very simplest
% transformations such as (x + 0) => x and (x * 1) => x. They may even
% go as far as (2 + 2) => 4, but do not guarantee even that! Note that
% "simplifications" along the lines illustrated here are naive and not
% in general an effective way to tidy things up.

symbolic procedure garnet!-simp!-plus l;
  begin
    scalar r, n;
    n := 0;
    for each x in l do
       if numberp x then n := n + x
       else r := x . r;
% Puts any numeric constant as first item in result version.
    if not zerop n then r := n . reverse r
    else r := reverse r;
% If only one item left return it, otherwise return a sum.
    if null cdr r then return car r
    else return 'plus . r
  end;

symbolic procedure garnet!-simp!-times l;
  begin
    scalar r, n;
    n := 1;
    for each x in l do
       if numberp x then n := n * x
       else r := x . r;
    if zerop n then return 0
    else if not onep n then r := n . reverse r
    else r := reverse r;
    if null cdr r then return car r
    else return 'times . r
  end;

symbolic procedure garnet!-simp!-difference l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    if numberp a and numberp b then return a-b
    else if zerop a then return garnet!-simp!-minus list b
    else if zerop b then return a
    else return list('difference, a, b)
  end;

symbolic procedure garnet!-simp!-quotient l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    if zerop a then return 0
    else if onep b then return a
    else return list('quotient, a, b)
  end;

% Adding garnet!-simp!-expt l
% Sean-To-do: seems that we cannot just simplify expt component
symbolic procedure garnet!-simp!-expt l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    return list('expt, a, b)
%    if zerop b then return 1
%    else if onep b then return a
%    else if zerop a then return 0
%    else if onep a then return a
%    else return list('expt, a, b)
  end;

symbolic procedure garnet!-simp!-minus l;
  begin
    scalar a;
    a := car l;
    if numberp a then return -a
    else if eqcar(a, 'minus) then return cadr a
    else return list('minus, a)
  end;

symbolic procedure garnet!-simpatom x;
  begin
    scalar w, n, d;
% Start by "simplifying" to get a Standard Quotient
    w := simp x;
% Factorize the polynomials in numerator and denominator;
    n := prepfctr fctrf numr w;
    d := prepfctr fctrf denr w;
    if d = 1 then return n
% WARNING: FOLLOWING IS A HACK
% Simple quotient rewrite rule when numberator is one
    else if onep n then <<
      if eqcar(d, 'expt) and (numberp caddr d) then
        return list('expt, cadr d, -(caddr d));
      >>

    else return list('quotient, n, d)
  end;

% fctrf returns a numerical content on the front of a list of
% factors and multiplicities. If it is (c . (f1 . n1) (f2 . n2)) I will
% return (times c (expt f1 n1) (expt f2 n2)). But can omit bits if any
% multiplicity is 1, or if c=1, or if there is only one factor shown at
% all.

symbolic procedure prepfctr u;
  begin
    scalar r;
    r := for each f in cdr u collect
      if cdr f = 1 then prepf car f
      else list('expt, prepf car f, cdr f);
    if null r then return car u
    else if car u = 1 then <<
      if null cdr r then return car r
      else return 'times . r >>
    else return 'times . car u . r
  end;

% tr garnet!-simpatom;
% tr fctrf, prepfctr;

% going through all the rules one by one for pattern matching

symbolic procedure garnet_integrate(a, x);
  begin
    scalar rules, w;
    rules := rubi_rules;
top:
    if null rules then return list('unsimplified_int, a, x);
% apply_rules returns a non-nil answer if it finds an integral, or nil
% if the rules will not apply.
    if w := apply_rule(car rules, a, x) then
       return garnet_check_inside w;
    rules := cdr rules;
    go to top;
  end;

global '(trace_counter);
trace_counter := 0;

% The high-level pattern matcher, match a rule against an expression
% calls trymatch to create bindings
% returns nil if fail to match
%
symbolic procedure apply_rule(rule, a, x);
  begin
    scalar lhs, rhs, conditions, w, bindings, condition;
    if (trace_counter := trace_counter+1) < 5 then <<
        %Sean-To-do: look up posn()
        %Arthur: posn() tells you the current output column, so this
        % forces a new line unless you are already at the start of a line.
       if posn() neq 0 then terpri();
       prin trace_counter; princ ": ";
       princ "looking at "; prin a; princ " wrt "; print x;
       princ "Try rule "; prettyprint rule; terpri() >>;
    if not eqcar(rule, '!/!;) then <<
       printc "Expecting /; at top of rule, rule is: "; % print rule;
       return nil >>;
    w := cadr rule;
    conditions := caddr rule;
    if not eqcar(w, '!:!=) then <<
       printc "Expecting := at top of rewrite";
       return nil >>;
    lhs := cadr w;
    rhs := caddr w;
% trymatch will return either a list of bindings or the special symbol
% 'fail to indicate that matching was not possible.
    bindings := trymatch(list('!Int, a, x), lhs, nil);
    princ "Bindings = "; print bindings;
    if bindings = 'fail then return nil;

    % following is a little test for check_fraction_q
    condition := '(!Fraction!Q (bracelist n p));
    single_condition_pass(condition, bindings, rhs);

% Here I need to check conditions
% Sean: do subla before checking conditions??
% Sean: doing subla on conditions before checking conditions
% I see no incidence of using the original conditions

    if conditions_pass(subla(bindings, conditions), subla(bindings, rhs))
      then return subla(bindings, rhs) % redundant call to subla
    else return nil;
  end;

% ===================== Conditions Section ======================
symbolic procedure conditions_pass(c, r);
  begin
    scalar first_cond, second_cond;
    if eqcar(c, 'and) then <<
%      printc "AND: checking if both conditions are true";

      first_cond := conditions_pass(cadr c, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else if first_cond then <<
        second_cond := conditions_pass(caddr c, r);
        if second_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car caddr c;
          return nil;
          >>
        else return second_cond;
        >>
      else return nil;
      >>
    else if eqcar(c, 'or) then <<
%      printc "OR: checking if one of the two conditions are true";
      first_cond := conditions_pass(cadr c, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else if first_cond then return t
      else  <<
        second_cond := conditions_pass(caddr c, r);
        if second_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car caddr c;
          return nil;
          >>
        else return second_cond;
        >>;
      >>
    else if eqcar(c, '!Not) then <<
%      printc "NOT: reverse logic";
      first_cond := conditions_pass(cadr c, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else return not first_cond;
      >>
    else return single_condition_pass(c, r);
  end;

%*****************List of All Conditions*************
% Ones without a * are not implemented
% Listed in the order of appearance

% *!Free!Q
% *!Fraction!Q
% *lessp
% *!Positive!Q
% *!Pos!Q
% *!Neg!Q
% !Not
% *!Zero!Q
% *greaterp
% *!Nonzero!Q
% !Rational!Q
% *!Integer!Q
% *!Integers!Q
% *leq
% !Match!Q
% *equal
% *!Negative!Q
% *geq
% nil
% !Polynomial!Q
% !Negative!Coefficient!Q
% !Linear!Q
% !If
% *neq
% !Algebraic!Function!Q
% *!Even!Q
% *!Odd!Q
% !Function!Of!Hyperbolic!Q
% !Function!Of!Q
% !Nonsum!Q
% !Try!Pure!Tanh!Subst
% !Independent!Q
% !Half!Integer!Q
% !Inverse!Function!Free!Q
% !False!Q
% !Coprime!Q
% !Expand!Integrand!Q
% !One!Q
% !Recognized!Function!Of!Trig!Q
% !Member!Q
% !Try!Pure!Tan!Subst

%****************************************************

symbolic procedure single_condition_pass(c, r);
  begin
% Passing (cdr c) for now to preserve structural integrity for various cases
% TO-DO: reorder according to the number of occurence
    if eqcar(c, '!Free!Q) then return check_free_q(cdr c, r)
    else if eqcar(c, '!Zero!Q) then return check_zero_q(cdr c)
    else if eqcar(c, '!Nonzero!Q) then return check_non_zero_q(cdr c)
    else if eqcar(c, 'equal) then return check_equal(cdr c)
    else if eqcar(c, 'neq) then return check_not_equal(cdr c)
    else if eqcar(c, '!Odd!Q) then return check_odd_q(cdr c)
    else if eqcar(c, '!Even!Q) then return check_even_q(cdr c)
    else if eqcar(c, '!Positive!Q) then return check_positive_q(cdr c)
    else if eqcar(c, '!Negative!Q) then return check_negative_q(cdr c)
    else if eqcar(c, '!Pos!Q) then return check_pos_q(cdr c)
    else if eqcar(c, '!Neg!Q) then return check_neg_q(cdr c)
    else if eqcar(c, 'lessp) then return check_lessp(cdr c)
    else if eqcar(c, '!greaterp) then return check_greaterp(cdr c)
    else if eqcar(c, 'leq) then return check_less_equal(cdr c)
    else if eqcar(c, 'geq) then return check_greater_equal(cdr c)
    else if eqcar(c, 'nil) then return check_nil(cdr c)
    else if eqcar(c, '!Independent!Q) then return check_independent_q(cdr c)
    else if eqcar(c, '!Match!Q) then return check_match_q(cdr c)
    else if eqcar(c, '!Integer!Q) then return check_integer_q(cdr c)
    else if eqcar(c, '!Integers!Q) then return check_integers_q(cdr c)
    else if eqcar(c, '!Rational!Q) then return check_rational_q(cdr c)
    else if eqcar(c, '!Fraction!Q) then return check_fraction_q(cdr c)
    else if eqcar(c, '!Polynomial!Q) then return check_polynomial_q(cdr c)
    else if eqcar(c, '!Linear!Q) then return check_linear_q(cdr c)
    else if eqcar(c, '!Function!Of!Q) then return check_function_of_q(cdr c)

    else if eqcar(c, '!Fraction!Or!Negative!Q) then
      return check_fraction_or_negative_q(cdr c)

    else if eqcar(c, '!Negative!Coefficient!Q) then
      return check_negative_coefficient_q(cdr c)

    else if eqcar(c, '!Algebraic!Function!Q) then
      return check_algebraic_function_q(cdr c)

    else if eqcar(c, '!Function!Of!Hyperbolic!Q) then
      return check_function_of_hyperbolic_q(cdr c)

    else if eqcar(c, '!Inverse!Function!Free!Q) then
      return check_inverse_function_free_q(cdr c)

    else if eqcar(c, '!Recognized!Function!Of!Trig!Q) then
      return check_recognized_function_of_trig_q(cdr c)

    else <<
      princ "Condition not recognised, need to add to current list: ";
      print c;
      return 'fail;
      >>;
    return nil;
  end;

% To-do: test it thoroughly - most frequent condition
% c: condition, in the form of ((bracelist a b c ...) x)
% r: right hand side
symbolic procedure check_free_q(c, r);
  begin
    mark_constants(r, car cdr c);
    for each h in (cdr car c) do
      if not gethash(h, garnet_hash) then go to top_free;
    return t;
top_free:
    return nil;
  end;

symbolic procedure check_zero_q(c);
  zerop reval(car c);

symbolic procedure check_non_zero_q(c);
  not check_zero_q(c);

% still a little puzzled by different equality test
symbolic procedure check_equal(c);
  reval car c = reval cadr c;

symbolic procedure check_not_equal(c);
  not check_equal(c);

symbolic procedure check_odd_q(c);
  oddp reval car c;

symbolic procedure check_even_q(c);
  evenp reval car c;

symbolic procedure check_positive_q(c);
  lessp_quotient(0, car c);

symbolic procedure check_negative_q(c);
  lessp_quotient(car c, 0);

symbolic procedure check_pos_q(c);
  lessp_quotient(0, car c);

symbolic procedure check_neg_q(c);
  lessp_quotient(car c, 0);

symbolic procedure check_lessp(c);
% need to check if they are rational first - rational_q not yet implemented
% if check_rational_q(car c) and check_rational_q(cadr c) then
  lessp_rubi(car c, cadr c);

% The (perculiar) behavior of reval:
% w := '(quotient 1 -2);
% reval w; => (quotient (minus 1) 2)
% reval cadr w; => 1;
% reval cadr reval w; => -1;

% lessp than compares quotient as well
symbolic procedure lessp_quotient(l, r);
  begin
    l := reval l;
    r := reval r;
    if numberp l and numberp r then return l < r
    else if eqcar(l, 'quotient) and numberp r then <<
      if zerop r then return eqcar(cadr l, 'minus)
      else if r > 0 then <<
        if eqcar(cadr l, 'minus) then return t % neg fraction < positive int
        else return lessp_quotient(list('times, cadr l, r), caddr l);
        >>
      else <<
        if eqcar(cadr l, 'minus) then % make both positive
          return lessp_quotient(list('minus, r), list('minus, l))
        else return nil;
        >>;
      >>
    else if numberp l and eqcar(r, 'quotient) then
      return not lessp_quotient(r, l)
    else if eqcar(l, 'quotient) and eqcar(r, 'quotient) then <<
% This part needs a bit more scrutinisation:
% we assume if we found a number at numerator, then the quotient
% is positive
      if eqcar(cadr l, 'minus) and eqcar(cadr r, 'minus) then
        return lessp_quotient(list('minus, r), list('minus, l))
      else if eqcar(cadr l, 'minus) and numberp cadr r then return t
      else if numberp cadr l and eqcar(cadr r, 'minus) then return nil
      else if numberp cadr l and numberp cadr r then
        return lessp_quotient(list('times,cadr l, caddr r),
          list('times, cadr r, caddr l))
      else rederr "Error comparing two quotients";
      >>
    else rederr "lessp_quotient cannot recognise the format";
  end;

symbolic procedure check_greaterp(c);
  not check_lessp(c);

symbolic procedure check_less_equal(c);
  check_equal(c) and check_lessp(c);

symbolic procedure check_greater_equal(c);
  check_equal(c) and not check_lessp(c);

symbolic procedure check_nil(c);
  'fail;
% Two cases for !Independent!Q, one followed by !Cancel, the other is not
symbolic procedure check_independent_q(c);
  'fail;
symbolic procedure check_match_q(c);
  'fail;

symbolic procedure check_integer_q(c);
  fixp reval car c;

symbolic procedure check_integers_q(c);
  if null c then t
  else <<
    if check_integer_q(car c) then check_integers_q(cdr c)
    else nil;
    >>;

symbolic procedure check_rational_q(c);
  'fail;

symbolic procedure check_fraction_q(c);
% !Fraction!Q can be either called on a single atom or a bracelist
% for eg. (!Fraction!Q n) and (!Fraction!Q (bracelist n p))
  if eqcar(c, 'bracelist) then check_fraction_q_list (cdr car c)
  else check_fraction_q_atom (car c);

symbolic procedure check_fraction_q_atom c;
% do a reval to force 'quotient to come to car of the list
% seems generally work but can't guarantee
  if atom reval c then nil
  else car reval c = 'quotient;

symbolic procedure check_fraction_q_list l;
  begin
    if null l then return t
    else if check_fraction_q_atom (car l) then <<
      l := cdr l;
      return check_fraction_q_list l;
      >>
    else return nil;
  end;

tr check_fraction_q, check_fraction_q_atom, check_fraction_q_list;

symbolic procedure check_polynomial_q(c);
  'fail;
symbolic procedure check_linear_q(c);
  'fail;
symbolic procedure check_function_of_q(c);
  'fail;
symbolic procedure check_fraction_or_negative_q(c);
  'fail;
symbolic procedure check_negative_coefficient_q(c);
  'fail;
symbolic procedure check_algebraic_function_q(c);
  'fail;
symbolic procedure check_function_of_hyperbolic_q(c);
  'fail;
symbolic procedure check_inverse_function_free_q(c);
  'fail;
symbolic procedure check_recognized_function_of_trig_q(c);
  'fail;

% ===================== Conditions Section End ======================

% the low-level recursive pattern matcher that generates bindings
% returns binding if succeed, 'fail otherwise
% bindings in the following format:
% (( rule_variable_name . expression_variable_name) (...) ...)
symbolic procedure trymatch(u, pattern, env);
  begin
%    princ "u = "; print u;
%    princ "pattern = "; print pattern;
%    princ "env = "; print env;
% Sean-To-do: what happens when there is '!_ or '!_!.??
    if eqcar(pattern, '!_) then
       return (cadr pattern . u) . env
    else if eqcar(pattern, '!_!.) then
       return (cadr pattern . u) . env
    else if u = pattern then return env
    else if atom pattern or atom u then return 'fail
    else if not (car u = car pattern) then return 'fail
    else return trymatchlist(cdr u, cdr pattern, env)
  end;

symbolic procedure trymatchlist(lu, lpattern, env);
  if null lu and null lpattern then env
  else if null lu or null lpattern then 'fail
  else begin
    scalar w;
    w := trymatch(car lu, car lpattern, env);

    % If using original expression fails to match, try rewriting our
    % expression to match the the pattern
    if w = 'fail then <<
      if eqcar(car lpattern, 'expt) then <<
        w := trymatch_expt(lu, lpattern, env);
        >>
      else if eqcar(car lpattern, 'times) then <<
        w := trymatch_times(lu, lpattern, env);
        >>
      else return 'fail;
      >>;
    if w = 'fail then return 'fail
    else return trymatchlist(cdr lu, cdr lpattern, w);
    end;

%======================Try Match with Options====================

% To-do: not fully implemented yet
% To-do: some redundant logic, will fix it when I have a clear mind

symbolic procedure trymatch_expt(lu, lpattern, env);
% princ "Attempting to add exponent 1.";
    if eqcar(caddr car lpattern, '!_ ) then
      trymatch(list('expt, car lu, 1), car lpattern, env)
    else 'fail;

symbolic procedure trymatch_times(lu, lpattern, env);
% princ "Attempting to add coefficient/times 1.";
  if eqcar(cadr car lpattern, '!_!. ) then
   trymatch(list('times, 1, car lu), car lpattern, env)
  else 'fail;

%======================Try Match with Options End================

% A rule may transform an integral into something where there is an
% integral sign left within what is generated. Scan to spot such cases and
% call garnet again to process that.

symbolic procedure garnet_check_inside u;
  if atom u then u
  else if eqcar(u, 'int) then garnet_integrate(cadr u, caddr u)
  else car u . for each a in cdr u collect garnet_check_inside a;

% A possibly useful function for noting constants. NOT TESTED AT ALL YET.

%Sean-To-do: will try to incorporate this at later stage

fluid '(garnet_hash);
garnet_hash := mkhash(15, 0, 2.0);

symbolic procedure mark_constants(u, x);
  begin
    clrhash garnet_hash;
    mark_constants_1(u, x)
  end;

% The idea is that this will enter data into the hash table for every
% part of the input that is "constant" in u (with respect to x). So complex
% formulae like sin(pi/sqrt(a^2+b^2)) are constant with respect to x, in that
% the given formula has no x in it. However exactly the same formula would not
% be independent of a or b.
% The functio also returns true it its argument u is independent of x,
% This is to implement the InvolvesQ predicate.

symbolic procedure mark_constants_1(u, x);
  if u = x then nil
  else if atom u then << puthash(u, garnet_hash, t); t >>
  else begin
    scalar overall;
    overall := t;
% overall is going to tell if this whole expression seems constant.
    for each s in cdr u do
       if not mark_constants_1(s, x) then overall := nil;
    if overall then puthash(u, garnet_hash, t);
    return overall
  end;

% check by using "gethash(u, garnet_hash)"

% Small test/demo of above

symbolic procedure test_constants(u, x);
  begin
    mark_constants(u, x);
    testconst u
  end;

symbolic procedure testconst u;
  begin
    prin u;
    if posn() > 49 then terpri();
    ttab 50;
    print gethash(u, garnet_hash);
    if atom u then return nil;
    for each s in cdr u do testconst s
  end;

test_constants('(plus (times 2 x)
                 (sin (quotient pi (sqrt (plus (expt a 2) (expt b 2)))))),
               'x);

algebraic;

% I now have some cases - where SOME of them should match the rule that
% I have got.

% tr trymatch, trymatchlist;

%garnet((u + v*z^(1/2))^(-1/2), z);
%garnet((u + z^1)^(-2), z);
%garnet((u + v*z)^(-2), z);
%garnet((u + z)^(-2), z);

% Now the same four but with a level of indirection...
% w := (u + v*z^1)^(-1/3); garnet(w, z);
%w := (u + z^1)^(-2); garnet(w, z);
%w := (u + v*z)^(-2); garnet(w, z);
%w := (u + z)^(-2); garnet(w, z);

end;

% This is not Rubi and Garnet is not as valuable as Ruby... but at least
% both are basically red...

lisp;
on backtrace, echo, comp; % set some useful (I hope) options

% The existing "rubi_red" package provides a way to access all the
% Rubi rules... But in fact I will set up my own short list...

% load_package rubi_red;

fluid '(rubi_rules);

% To start with I will have just ONE rule!

% (a + b*x^n)^p
% where n*(p+1)=-1
% eg let me try n=1, p=-2, so I get
% (a + b*x^1)^(-2)

rubi_rules := '(

(!/!;
   (!:!=
      (!Int
         (expt (plus (!_ a) (times (!_!. b) (expt (!_ x) (!_ n)))) (!_ p))
         (!_ x !Symbol))
      (quotient (times x (expt (plus a (times b (expt x n))) (plus p 1))) a))
   (and
      (!Free!Q (bracelist a b n p) x)
      (!Zero!Q (plus (times n (plus p 1)) 1))))

)$

algebraic operator unsimplified_int;

symbolic procedure simpgarnet u;
  begin
    scalar a, x, r;
    if length u neq 2 then rederr "garnet requires two arguments";
    a := car u;
    x := cadr u;
    if posn() neq 0 then terpri();
    princ "Integrate "; prin a; princ " wrt "; print x;
% The arguments arrive here are totally unprocessed, and so for instance
% if you write "w := <something>; var := x; garnet(w, var);" what you
% receive will be "w" and "var" not sensible values. I have special code
% to deal with this!
    a := garnet!-simp a;
    x := garnet!-simp x;
    r := garnet_integrate(a, x);
% I hand back a list of length 2 - the first item is the result that
% garnet generates, the second is what the existing old Reduce integrator
% makes of the example.
    return simp list('list, r, list('int, a, x));
  end;

put('garnet, 'simpfn, 'simpgarnet);

% This takes a formula and "evaluates" it by evaluating all the variables
% present in it while trying to preserve the structure around the, So if you
% hand it (x-1)^10 where x has some messy value it will return the expression
% (<messy-value> - 1)^10 rather than multiplying things out. Just in case
% the varibles used had previously been simplified in a way that expanded
% them this does some factorization to try to return things to a "neat"
% form. If substituting values for variables would introduce cases of
% (expression + 0) or (expression^1) it does some minor tidying up to
% make things seem nicer.

symbolic procedure garnet!-simp u;
  if numberp u then u
  else if atom u then garnet!-simpatom u
  else begin
    scalar w;
    w := for each v in cdr u collect garnet!-simp v;
    if car u = 'plus then return garnet!-simp!-plus w
    else if car u = 'difference then return garnet!-simp!-difference w
    else if car u = 'times then return garnet!-simp!-times w
    else if car u = 'quotient then return garnet!-simp!-quotient w
    else if car u = 'expt then return garnet!-simp!-expt w
    else if car u = 'minus then return garnet!-simp!-minus w
    else return car u . w
  end;

% Following might be redundant - commented out for the moment

%symbolic procedure garnet!-simp!-plus l;
%  begin
%    scalar r;
%    for each x in l do if not zerop x then r := x . r;
%    if null r then return 0
%    else if nuill cdr r then return car r
%    else return 'plus . reverse r
%  end;

% The next few reconstruct prefix forms performing only the very simplest
% transformations such as (x + 0) => x and (x * 1) => x. They may even
% go as far as (2 + 2) => 4, but do not guarantee even that! Note that
% "simplifications" along the lines illustrated here are naive and not
% in general an effective way to tidy things up.

symbolic procedure garnet!-simp!-plus l;
  begin
    scalar r, n;
    n := 0;
    for each x in l do
       if numberp x then n := n + x
       else r := x . r;
% Puts any numeric constant as first item in result version.
    if not zerop n then r := n . reverse r
    else r := reverse r;
% If only one item left return it, otherwise return a sum.
    if null cdr r then return car r
    else return 'plus . r
  end;

symbolic procedure garnet!-simp!-times l;
  begin
    scalar r, n;
    n := 1;
    for each x in l do
       if numberp x then n := n * x
       else r := x . r;
    if zerop n then return 0
    else if not onep n then r := n . reverse r
    else r := reverse r;
    if null cdr r then return car r
    else return 'times . r
  end;

symbolic procedure garnet!-simp!-difference l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    if numberp a and numberp b then return a-b
    else if zerop a then return garnet!-simp!-minus list b
    else if zerop b then return a
    else return list('difference, a, b)
  end;

symbolic procedure garnet!-simp!-quotient l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    if zerop a then return 0
    else if onep b then return a
    else return list('quotient, a, b)
  end;

% Adding garnet!-simp!-expt l
% Sean-To-do: seems that we cannot just simplify expt component
symbolic procedure garnet!-simp!-expt l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    return list('expt, a, b)
%    if zerop b then return 1
%    else if onep b then return a
%    else if zerop a then return 0
%    else if onep a then return a
%    else return list('expt, a, b)
  end;

symbolic procedure garnet!-simp!-minus l;
  begin
    scalar a;
    a := car l;
    if numberp a then return -a
    else if eqcar(a, 'minus) then return cadr a
    else return list('minus, a)
  end;

symbolic procedure garnet!-simpatom x;
  begin
    scalar w, n, d;
% Start by "simplifying" to get a Standard Quotient
    w := simp x;
% Factorize the polynomials in numerator and denominator;
    n := prepfctr fctrf numr w;
    d := prepfctr fctrf denr w;
    if d = 1 then return n
% WARNING: FOLLOWING IS A HACK
% Simple quotient rewrite rule when numberator is one
    else if onep n then <<
      if eqcar(d, 'expt) and (numberp caddr d) then
        return list('expt, cadr d, -(caddr d));
      >>

    else return list('quotient, n, d)
  end;

% fctrf returns a numerical content on the front of a list of
% factors and multiplicities. If it is (c . (f1 . n1) (f2 . n2)) I will
% return (times c (expt f1 n1) (expt f2 n2)). But can omit bits if any
% multiplicity is 1, or if c=1, or if there is only one factor shown at
% all.

symbolic procedure prepfctr u;
  begin
    scalar r;
    r := for each f in cdr u collect
      if cdr f = 1 then prepf car f
      else list('expt, prepf car f, cdr f);
    if null r then return car u
    else if car u = 1 then <<
      if null cdr r then return car r
      else return 'times . r >>
    else return 'times . car u . r
  end;

% tr garnet!-simpatom;
% tr fctrf, prepfctr;

% going through all the rules one by one for pattern matching

symbolic procedure garnet_integrate(a, x);
  begin
    scalar rules, w;
    rules := rubi_rules;
top:
    if null rules then return list('unsimplified_int, a, x);
% apply_rules returns a non-nil answer if it finds an integral, or nil
% if the rules will not apply.
    if w := apply_rule(car rules, a, x) then
       return garnet_check_inside w;
    rules := cdr rules;
    go to top;
  end;

global '(trace_counter);
trace_counter := 0;

% The high-level pattern matcher, match a rule against an expression
% calls trymatch to create bindings
% returns nil if fail to match
%
symbolic procedure apply_rule(rule, a, x);
  begin
    scalar lhs, rhs, conditions, w, bindings, condition;
    if (trace_counter := trace_counter+1) < 5 then <<
        %Sean-To-do: look up posn()
        %Arthur: posn() tells you the current output column, so this
        % forces a new line unless you are already at the start of a line.
       if posn() neq 0 then terpri();
       prin trace_counter; princ ": ";
       princ "looking at "; prin a; princ " wrt "; print x;
       princ "Try rule "; prettyprint rule; terpri() >>;
    if not eqcar(rule, '!/!;) then <<
       printc "Expecting /; at top of rule, rule is: "; % print rule;
       return nil >>;
    w := cadr rule;
    conditions := caddr rule;
    if not eqcar(w, '!:!=) then <<
       printc "Expecting := at top of rewrite";
       return nil >>;
    lhs := cadr w;
    rhs := caddr w;
% trymatch will return either a list of bindings or the special symbol
% 'fail to indicate that matching was not possible.
    bindings := trymatch(list('!Int, a, x), lhs, nil);
    princ "Bindings = "; print bindings;
    if bindings = 'fail then return nil;

    % following is a little test for check_fraction_q
    condition := '(!Fraction!Q (bracelist n p));
    single_condition_pass(condition, bindings, rhs);

% Here I need to check conditions
% Sean: do subla before checking conditions??
    if conditions_pass(conditions, bindings, rhs) then return subla(bindings, rhs)
    else return nil;
  end;

% ===================== Conditions Section ======================
symbolic procedure conditions_pass(c, b, r);
  begin
    scalar first_cond, second_cond;
%    princ "Conditions are: "; print c;
%    princ "Bindings are: "; print b;
    if eqcar(c, 'and) then <<
%      printc "AND: checking if both conditions are true";

      first_cond := conditions_pass(cadr c, b, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else if first_cond then <<
        second_cond := conditions_pass(caddr c, b, r);
        if second_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car caddr c;
          return nil;
          >>
        else return second_cond;
        >>
      else return nil;
      >>
    else if eqcar(c, 'or) then <<
%      printc "OR: checking if one of the two conditions are true";
      first_cond := conditions_pass(cadr c, b, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else if first_cond then return t
      else  <<
        second_cond := conditions_pass(caddr c, b, r);
        if second_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car caddr c;
          return nil;
          >>
        else return second_cond;
        >>;
      >>
    else if eqcar(c, '!Not) then <<
%      printc "NOT: reverse logic";
      first_cond := conditions_pass(cadr c, b, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else return not first_cond;
      >>
    else return single_condition_pass(c, b, r);
  end;

%*****************List of All Conditions*************
% Some are not implemented
% Listed in the order of appearance

% !Free!Q
% !Fraction!Q
% lessp
% !Positive!Q
% !Pos!Q
% !Neg!Q
% !Not
% !Zero!Q
% greaterp
% !Nonzero!Q
% !Rational!Q
% !Integer!Q
% !Integers!Q
% leq
% !Match!Q
% equal
% !Negative!Q
% geq
% nil
% !Polynomial!Q
% !Negative!Coefficient!Q
% !Linear!Q
% !If
% neq
% !Algebraic!Function!Q
% !Even!Q
% !Odd!Q
% !Function!Of!Hyperbolic!Q
% !Function!Of!Q
% !Nonsum!Q
% !Try!Pure!Tanh!Subst
% !Independent!Q
% !Half!Integer!Q
% !Inverse!Function!Free!Q
% !False!Q
% !Coprime!Q
% !Expand!Integrand!Q
% !One!Q
% !Recognized!Function!Of!Trig!Q
% !Member!Q
% !Try!Pure!Tan!Subst

%****************************************************

symbolic procedure single_condition_pass(c, b, r);
  begin
% Passing (cdr c) for now to preserve structural integrity for various cases
    if eqcar(c, '!Free!Q) then return check_free_q(cdr c, b, r)
    else if eqcar(c, '!Zero!Q) then return check_zero_q(cdr c, b)
    else if eqcar(c, '!Nonzero!Q) then return check_non_zero_q(cdr c, b)
    else if eqcar(c, 'equal) then return check_equal(cdr c, b)
    else if eqcar(c, 'neq) then return check_not_equal(cdr c, b)
    else if eqcar(c, '!Odd!Q) then return check_odd_q(cdr c, b)
    else if eqcar(c, '!Even!Q) then return check_even_q(cdr c, b)
    else if eqcar(c, '!Positive!Q) then return check_positive_q(cdr c, b)
    else if eqcar(c, '!Negative!Q) then return check_negative_q(cdr c, b)
    else if eqcar(c, '!Pos!Q) then return check_pos_q(cdr c, b)
    else if eqcar(c, '!Neg!Q) then return check_neg_q(cdr c, b)
    else if eqcar(c, 'lessp) then return check_lessp(cdr c, b)
    else if eqcar(c, '!greaterp) then return check_greaterp(cdr c, b)
    else if eqcar(c, 'leq) then return check_less_equal(cdr c, b)
    else if eqcar(c, 'geq) then return check_greater_equal(cdr c, b)
    else if eqcar(c, 'nil) then return check_nil(cdr c, b)
    else if eqcar(c, '!Independent!Q) then return check_independent_q(cdr c, b)
    else if eqcar(c, '!Match!Q) then return check_match_q(cdr c, b)
    else if eqcar(c, '!Integer!Q) then return check_integer_q(cdr c, b)
    else if eqcar(c, '!Integers!Q) then return check_integers_q(cdr c, b)
    else if eqcar(c, '!Rational!Q) then return check_rational_q(cdr c, b)
    else if eqcar(c, '!Fraction!Q) then return check_fraction_q(cdr c, b)
    else if eqcar(c, '!Polynomial!Q) then return check_polynomial_q(cdr c, b)
    else if eqcar(c, '!Linear!Q) then return check_linear_q(cdr c, b)
    else if eqcar(c, '!Function!Of!Q) then return check_function_of_q(cdr c, b)

    else if eqcar(c, '!Fraction!Or!Negative!Q) then
      return check_fraction_or_negative_q(cdr c, b)

    else if eqcar(c, '!Negative!Coefficient!Q) then
      return check_negative_coefficient_q(cdr c, b)

    else if eqcar(c, '!Algebraic!Function!Q) then
      return check_algebraic_function_q(cdr c, b)

    else if eqcar(c, '!Function!Of!Hyperbolic!Q) then
      return check_function_of_hyperbolic_q(cdr c, b)

    else if eqcar(c, '!Inverse!Function!Free!Q) then
      return check_inverse_function_free_q(cdr c, b)

    else if eqcar(c, '!Recognized!Function!Of!Trig!Q) then
      return check_recognized_function_of_trig_q(cdr c, b)

    else <<
      princ "Condition not recognised, need to add to current list: ";
      print c;
      return 'fail;
      >>;
    return nil;
  end;

% To-do: test it thoroughly - most frequent condition
% c: condition, in the form of ((bracelist a b c ...) x)
% b: binding
% r: right hand side
symbolic procedure check_free_q(c, b, r);
  begin
    d := subla(b, c);
    r := subla(b, r);
    mark_constants(r, car cdr d);
    for each h in (cdr car d) do
      if not gethash(h, garnet_hash) then go to top_free;
    return t;
top_free:
    return nil;
  end;

symbolic procedure check_zero_q(c, b);
  zerop reval(car subla(b,c));

symbolic procedure check_non_zero_q(c, b);
  not check_zero_q(c,b);

symbolic procedure check_equal(c, b);
  'fail;
symbolic procedure check_not_equal(c, b);
  'fail;
symbolic procedure check_odd_q(c, b);
  'fail;
symbolic procedure check_even_q(c, b);
  'fail;
symbolic procedure check_positive_q(c, b);
  'fail;
symbolic procedure check_negative_q(c, b);
  'fail;
symbolic procedure check_pos_q(c, b);
  'fail;
symbolic procedure check_neg_q(c, b);
  'fail;
symbolic procedure check_lessp(c, b);
 'fail;
symbolic procedure check_greaterp(c, b);
 'fail;
symbolic procedure check_less_equal(c, b);
  'fail;
symbolic procedure check_greater_equal(c, b);
  'fail;
symbolic procedure check_nil(c, b);
  'fail;
% Two cases for !Independent!Q, one followed by !Cancel, the other is not
symbolic procedure check_independent_q(c, b);
  'fail;
symbolic procedure check_match_q(c, b);
  'fail;
symbolic procedure check_integer_q(c, b);
  'fail;
symbolic procedure check_integers_q(c, b);
  'fail;
symbolic procedure check_rational_q(c, b);
  'fail;

symbolic procedure check_fraction_q(c, b);
% !Fraction!Q can be either called on a single atom or a bracelist
% for eg. (!Fraction!Q n) and (!Fraction!Q (bracelist n p))
  begin
    scalar d;
    % Sean: not sure what happens to the 'bracelist' when we do subla
    d := subla(b,c);
    if atom car c then
      return check_fraction_q_atom car d
    else
      return check_fraction_q_list cdr car d;
  end;

symbolic procedure check_fraction_q_atom a;
% do a reval to force 'quotient to come to car of the list
% seems generally work but can't guarantee
  if atom a then nil
  else car reval a = 'quotient;

symbolic procedure check_fraction_q_list l;
  begin
    if null l then return t
    else if check_fraction_q_atom (car l) then <<
      l := cdr l;
      return check_fraction_q_list l;
      >>
    else return nil;
  end;

tr check_fraction_q, check_fraction_q_atom, check_fraction_q_list;

symbolic procedure check_polynomial_q(c, b);
  'fail;
symbolic procedure check_linear_q(c, b);
  'fail;
symbolic procedure check_function_of_q(c, b);
  'fail;
symbolic procedure check_fraction_or_negative_q(c, b);
  'fail;
symbolic procedure check_negative_coefficient_q(c, b);
  'fail;
symbolic procedure check_algebraic_function_q(c, b);
  'fail;
symbolic procedure check_function_of_hyperbolic_q(c, b);
  'fail;
symbolic procedure check_inverse_function_free_q(c, b);
  'fail;
symbolic procedure check_recognized_function_of_trig_q(c, b);
  'fail;

% ===================== Conditions Section End ======================

% the low-level recursive pattern matcher that generates bindings
% returns binding if succeed, 'fail otherwise
% bindings in the following format:
% (( rule_variable_name . expression_variable_name) (...) ...)
symbolic procedure trymatch(u, pattern, env);
  begin
%    princ "u = "; print u;
%    princ "pattern = "; print pattern;
%    princ "env = "; print env;
% Sean-To-do: what happens when there is '!_ or '!_!.??
    if eqcar(pattern, '!_) then
       return (cadr pattern . u) . env
    else if eqcar(pattern, '!_!.) then
       return (cadr pattern . u) . env
    else if u = pattern then return env
    else if atom pattern or atom u then return 'fail
    else if not (car u = car pattern) then return 'fail
    else return trymatchlist(cdr u, cdr pattern, env)
  end;

symbolic procedure trymatchlist(lu, lpattern, env);
  if null lu and null lpattern then env
  else if null lu or null lpattern then 'fail
  else begin
    scalar w;
    w := trymatch(car lu, car lpattern, env);

    % If using original expression fails to match, try rewriting our
    % expression to match the the pattern
    if w = 'fail then <<
      if eqcar(car lpattern, 'expt) then <<
        w := trymatch_expt(lu, lpattern, env);
        >>
      else if eqcar(car lpattern, 'times) then <<
        w := trymatch_times(lu, lpattern, env);
        >>
      else return 'fail;
      >>;
    if w = 'fail then return 'fail
    else return trymatchlist(cdr lu, cdr lpattern, w);
    end;

%======================Try Match with Options====================

% To-do: not fully implemented yet
% To-do: some redundant logic, will fix it when I have a clear mind

symbolic procedure trymatch_expt(lu, lpattern, env);
% princ "Attempting to add exponent 1.";
    if eqcar(caddr car lpattern, '!_ ) then
      trymatch(list('expt, car lu, 1), car lpattern, env)
    else 'fail;

symbolic procedure trymatch_times(lu, lpattern, env);
% princ "Attempting to add coefficient/times 1.";
  if eqcar(cadr car lpattern, '!_!. ) then
   trymatch(list('times, 1, car lu), car lpattern, env)
  else 'fail;

%======================Try Match with Options End================

% A rule may transform an integral into something where there is an
% integral sign left within what is generated. Scan to spot such cases and
% call garnet again to process that.

symbolic procedure garnet_check_inside u;
  if atom u then u
  else if eqcar(u, 'int) then garnet_integrate(cadr u, caddr u)
  else car u . for each a in cdr u collect garnet_check_inside a;

% A possibly useful function for noting constants. NOT TESTED AT ALL YET.

%Sean-To-do: will try to incorporate this at later stage

fluid '(garnet_hash);
garnet_hash := mkhash(15, 0, 2.0);

symbolic procedure mark_constants(u, x);
  begin
    clrhash garnet_hash;
    mark_constants_1(u, x)
  end;

% The idea is that this will enter data into the hash table for every
% part of the input that is "constant" in u (with respect to x). So complex
% formulae like sin(pi/sqrt(a^2+b^2)) are constant with respect to x, in that
% the given formula has no x in it. However exactly the same formula would not
% be independent of a or b.
% The functio also returns true it its argument u is independent of x,
% This is to implement the InvolvesQ predicate.

symbolic procedure mark_constants_1(u, x);
  if u = x then nil
  else if atom u then << puthash(u, garnet_hash, t); t >>
  else begin
    scalar overall;
    overall := t;
% overall is going to tell if this whole expression seems constant.
    for each s in cdr u do
       if not mark_constants_1(s, x) then overall := nil;
    if overall then puthash(u, garnet_hash, t);
    return overall
  end;

% check by using "gethash(u, garnet_hash)"

% Small test/demo of above

symbolic procedure test_constants(u, x);
  begin
    mark_constants(u, x);
    testconst u
  end;

symbolic procedure testconst u;
  begin
    prin u;
    if posn() > 49 then terpri();
    ttab 50;
    print gethash(u, garnet_hash);
    if atom u then return nil;
    for each s in cdr u do testconst s
  end;

test_constants('(plus (times 2 x)
                 (sin (quotient pi (sqrt (plus (expt a 2) (expt b 2)))))),
               'x);

algebraic;

% I now have some cases - where SOME of them should match the rule that
% I have got.

% tr trymatch, trymatchlist;

 garnet((u + v*z^(1/2))^(-1/2), z);
%garnet((u + z^1)^(-2), z);
%garnet((u + v*z)^(-2), z);
%garnet((u + z)^(-2), z);

% Now the same four but with a level of indirection...
% w := (u + v*z^1)^(-1/3); garnet(w, z);
%w := (u + z^1)^(-2); garnet(w, z);
%w := (u + v*z)^(-2); garnet(w, z);
%w := (u + z)^(-2); garnet(w, z);

end;