refactored interpreter

refactored interpreter

Red []

{
subleq a, b, c   ; Mem[b] = Mem[b] - Mem[a]
                 ; if (Mem[b] = 0) goto c

. at start means it's not an instruction
. a:b defines a label a to be b
. a:  defines a label for a position
z always = 0

? ; jump to next line
a ; same as a a ?
a b ; same as a b ?

a = 0
a a  => a = a - a = 0
a a

jmp c
Z Z c ; 0-0=0, jmp c

add a, b
a Z ; Z = Z - a = -a
Z b ; b = b - z = b - -a = b + a
Z Z ; Z = Z - Z = 0

mov a, b
b b ; b = 0
a Z ; Z = -a
Z b ; b = a + 0 = a
Z Z ; Z = 0
}

do %functional.red

parser: function [lines [string!]][
] [
 low_level_parser lines
]

low_level_parser: function [lines [string!]][
    memory: copy []
    label-table: make map! []
    patching-table: make map! []

    minus:      charset "-"
    hash:       charset "#"
    semi_colon: charset ";"
    eol:        [semi_colon | newline]

    digit:      charset "0123456789"
    letters:    charset [#"A" - #"Z" #"a" - #"z" ]
    alphanum:   union letters digit

    number:     [some digit]
    address:    [number | minus number]
    variable:   [some alphanum]
    location:   [address | variable]

    label-left: [
        copy data
        some alphanum
        (label-table/(data): length? memory)
    ]

    label-right: [
        copy data
         [":" any space opt minus some alphanum]
        (
            label-data: trim (pick split data ":" 2)
            append memory label-data
        )
    ]

    label: [
        any space "." any space label-left any space opt label-right
    ]

    thing-with-action: [
            copy data
            address
            (append memory data)
        |
            copy data
            variable
            (
                append memory 0
                patching-table/(length? memory ): data
            )
    ]

    three: [location space location space location]
    two: [location space location]
    one: [location]

    ;we need two different matching steps: first is just to match, second is to output the correct instructions
    command: [
            copy data
            three
            (
                parse data [thing-with-action space thing-with-action space thing-with-action]
            )
        |
            copy data
            two
            (
                parse data [thing-with-action space thing-with-action]
                append memory add length? memory 1
            )
        |
            copy data
            one
            (
                loop 2 [parse data [thing-with-action]]
                append memory add length? memory 2
            )
    ]

    rules: [
        any [
                [space | hash thru newline | eol]
            |
                [label | command]
        ]
    ]

    parse lines rules

    ;patches in any variables
    foreach key keys-of patching-table [
        poke memory key label-table/(patching-table/(key))
    ]

    ;converts all strings like "1"
    memory: f_map lambda [to-integer ?] memory
    memory
]

step_interpreter: function [
  memory [block!] "the subleq code to execute"
  pc [integer!] "the current program counter"
][
    output_string: copy [] ; each line of output is a new element in the block
    finished: false

    append/only output_string copy memory

    ;ask ""
    ; will exit from the if block if a throw is evaluated
    ; interpretation is finished if an error is thrown or we are at the end of the memory
    either error? err: try [ catch [
        a: pick memory add pc 1
        b: pick memory add pc 2
        c: pick memory add pc 3
        real_a: add a 1
        real_b: add b 1

        if (none? c) [
            append output_string "c is none"
            throw "c is none"
        ]

        append output_string (append copy "pc: " pc)
        append output_string (append copy "a: " a)
        append output_string (append copy "b: " b)
        append output_string (append copy "c: " c)

        case [
            c >= -1 [ memory/(real_b): memory/(real_b) - memory/(real_a) ]
            c == -1 [ finished: true ]
            c == -2 [
                if error? memory/(real_a): to-integer input [
                    memory/(real_a): to-string input
                ]
            ]
            c == -3 [ attempt append output_string to-string memory/(real_a) ]
            true    [ append output_string "c < -3"  throw "c < -3" ]
        ]

        append output_string (copy "")

        either all [
            b >= 0
            memory/(real_b) <= 0
            c >= 0
        ] [
            pc: c
        ] [
            pc: add pc 3
        ]
    ]] [
        finished: true
    ] [
        finished: finished or (pc + 3) >= (length? memory)
    ]

    return make map! compose/only [
      finished: (finished)
      memory: (memory)
      pc: (pc)
      output_string: (output_string)
      error: (err)
    ]
]

Red []

{
subleq a, b, c   ; Mem[b] = Mem[b] - Mem[a]
                 ; if (Mem[b] = 0) goto c

. at start means it's not an instruction
. a:b defines a label a to be b
. a:  defines a label for a position
z always = 0

? ; jump to next line
a ; same as a a ?
a b ; same as a b ?

a = 0
a a  => a = a - a = 0
a a

jmp c
Z Z c ; 0-0=0, jmp c

add a, b
a Z ; Z = Z - a = -a
Z b ; b = b - z = b - -a = b + a
Z Z ; Z = Z - Z = 0

mov a, b
b b ; b = 0
a Z ; Z = -a
Z b ; b = a + 0 = a
Z Z ; Z = 0
}

do %functional.red

parser: function [lines [string!]][
] [
 low_level_parser lines
]

low_level_parser: function [lines [string!]][
    memory: copy []
    label-table: make map! []
    patching-table: make map! []

    minus:      charset "-"
    hash:       charset "#"
    semi_colon: charset ";"
    eol:        [semi_colon | newline]

    digit:      charset "0123456789"
    letters:    charset [#"A" - #"Z" #"a" - #"z" ]
    alphanum:   union letters digit

    number:     [some digit]
    address:    [number | minus number]
    variable:   [some alphanum]
    location:   [address | variable]

    label-left: [
        copy data
        some alphanum
        (label-table/(data): length? memory)
    ]

    label-right: [
        copy data
         [":" any space opt minus some alphanum]
        (
            label-data: trim (pick split data ":" 2)
            append memory label-data
        )
    ]

    label: [
        any space "." any space label-left any space opt label-right
    ]

    thing-with-action: [
            copy data
            address
            (append memory data)
        |
            copy data
            variable
            (
                append memory 0
                patching-table/(length? memory ): data
            )
    ]

    three: [location space location space location]
    two: [location space location]
    one: [location]

    ;we need two different matching steps: first is just to match, second is to output the correct instructions
    command: [
            copy data
            three
            (
                parse data [thing-with-action space thing-with-action space thing-with-action]
            )
        |
            copy data
            two
            (
                parse data [thing-with-action space thing-with-action]
                append memory add length? memory 1
            )
        |
            copy data
            one
            (
                loop 2 [parse data [thing-with-action]]
                append memory add length? memory 2
            )
    ]

    rules: [
        any [
                [space | hash thru newline | eol]
            |
                [label | command]
        ]
    ]

    parse lines rules

    ;patches in any variables
    foreach key keys-of patching-table [
        poke memory key label-table/(patching-table/(key))
    ]

    ;converts all strings like "1"
    memory: f_map lambda [to-integer ?] memory
    memory
]

step_interpreter: function [
  memory [block!] "the subleq code to execute"
  pc [integer!] "the current program counter"
][
    output_string: copy [] ; each line of output is a new element in the block
    finished: false

    append/only output_string copy memory

    ;ask ""
    ; will exit from the if block if a throw is evaluated
    ; interpretation is finished if an error is thrown or we are at the end of the memory
    either error? err: try [ catch [
        a: pick memory add pc 1
        b: pick memory add pc 2
        c: pick memory add pc 3
        real_a: add a 1
        real_b: add b 1

        if (none? c) [
            append output_string "c is none"
            throw "c is none"
        ]

        append output_string (append copy "pc: " pc)
        append output_string (append copy "a: " a)
        append output_string (append copy "b: " b)
        append output_string (append copy "c: " c)

        either (b == -1) [
            if error? memory/(real_a): to-integer input [
                memory/(real_a): to-integer to-string input
            ]
        ] [
            either (b == -2) [
                output_character: to-string pick memory real_a
                attempt append output_string output_character
            ] [
                memory/(real_b): memory/(real_b) - memory/(real_a)
            ]
        ]

        if (c < -1) [
            append output_string "c < -1"
            throw "c < -1"
        ]

        append output_string (copy "")

        either all [
            b >= 0
            memory/(real_b) <= 0
            c >= 0
        ] [
            pc: c
        ] [
            pc: add pc 3
        ]
    ]] [
        finished: true
    ] [
        finished: (pc + 3) >= (length? memory)

    return make map! compose/only [
      finished: (finished)
      memory: (memory)
      pc: (pc)
      output_string: (output_string)
      error: (err)
    ]
]


FIX: issue #817 (How to quote a path)

FIX: issue #817 (How to quote a path)

Red [
	Title:   "Red runtime lexer"
	Author:  "Nenad Rakocevic"
	File: 	 %lexer.red
	Tabs:	 4
	Rights:  "Copyright (C) 2014 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
	}
]

trans-integer: routine [
	start [string!]
	end	  [string!]
	/local
		c	 [integer!]
		n	 [integer!]
		m	 [integer!]
		len  [integer!]
		p	 [byte-ptr!]
		neg? [logic!]
][
	str:  GET_BUFFER(start)
	unit: GET_UNIT(str)
	p:	  string/rs-head start
	len:  end/head - start/head
	neg?: no

	c: string/get-char p unit
	if any [
		c = as-integer #"+"
		c = as-integer #"-"
	][
		neg?: c = as-integer #"-"
		p: p + unit
		len: len - 1
	]
	n: 0
	until [
		c: (string/get-char p unit) - #"0"

		m: n * 10
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		if all [n = 2147483640 c = 8][
			integer/box 80000000h						;-- special exit trap for -2147483648
			exit
		]

		m: n + c
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		p: p + unit
		len: len - 1
		zero? len
	]
	integer/box either neg? [0 - n][n]
]

trans-hexa: routine [
	start	[string!]
	end		[string!]
	return: [integer!]
	/local
		s	  [series!]
		unit  [integer!]
		p	  [byte-ptr!]
		head  [byte-ptr!]
		p4	  [int-ptr!]
		n	  [integer!]
		power [integer!]
		cp	  [byte!]
][
	s: GET_BUFFER(start)
	unit: GET_UNIT(s)

	p: (string/rs-head end) - unit
	head: string/rs-head start

	n: 0
	power: 0
	while [p >= head][
		cp: switch unit [
			Latin1 [p/value]
			UCS-2  [as-byte ((as-integer p/2) << 8 + p/1)]
			UCS-4  [p4: as int-ptr! p as-byte p4/value]
		]
		if cp <> #"0" [
			case [
				all [#"0" <= cp cp <= #"9"][cp: cp - #"0"]
				all [#"A" <= cp cp <= #"F"][cp: cp - #"A" + 10]
				all [#"a" <= cp cp <= #"f"][cp: cp - #"a" + 10]
			]
			n: n + ((as-integer cp) << power)
		]
		power: power + 4
		p: p - unit
	]
	n
]

trans-char: routine [
	start	[string!]
	end		[string!]
	/local
		n	  [integer!]
		value [red-value!]
][
	n: trans-hexa start end
	value: as red-value! integer/box n
	set-type value TYPE_CHAR
]

trans-push-path: routine [
	stack [block!]
	type  [datatype!]
	/local
		path [red-path!]
][
	path: as red-path! block/make-at as red-block! ALLOC_TAIL(stack) 4
	path/header: switch type/value [
		TYPE_GET_WORD [TYPE_GET_PATH]
		TYPE_LIT_WORD [TYPE_LIT_PATH]
		default [TYPE_PATH]
	]
]

trans-set-path: routine [
	stack [block!]
	/local
		path [red-path!]
][
	path: as red-path! block/pick stack 1 null
	set-type as red-value! path TYPE_SET_PATH
]

trans-make-word: routine [
	src   [string!]
	type  [datatype!]
][
	set-type
		as red-value! word/box (symbol/make-alt src) ;-- word/box puts it in stack/arguments
		type/value
]

trans-word: func [
	stack [block!]
	src   [string!]
	type  [datatype!]
][
	trans-store stack trans-make-word src type
]

trans-pop: function [stack [block!]][
	value: last stack
	remove back tail stack

	either any [1 < length? stack head? stack/1][
		append/only last stack :value
	][
		pos: back tail stack							;-- root storage and offset-ed series (/into option)
		pos/1: insert/only last stack :value
	]
]

trans-store: function [stack [block!] value][
	either any [1 < length? stack head? stack/1][
		append last stack value
	][
		pos: back tail stack							;-- root storage and offset-ed series (/into option)
		pos/1: insert last stack value
	]
]

transcode: function [
	src	[string!]
	dst	[block! none!]
	/part
		length [integer! string!]
	return: [block!]
	/local
		new s e c hex pos value cnt type process
		digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
		not-file-char not-str-char not-mstr-char caret-char
		non-printable-char integer-end ws-ASCII ws-U+2k control-char
][
	cs:		[- - - - - - - - - - - - - - - -]			;-- memoized bitsets
	stack:	clear []
	count?:	yes											;-- if TRUE, lines counter is enabled
	line: 	1

	append/only stack any [dst make block! 4]

	trans-string: [
		new: make type (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				escaped-char (append new value)
				| #"^^"									;-- trash single caret chars
				| set c skip (append new c)
			]
		]
		new
	]

	trans-file: [
		new: make type (index? e) - index? s
		append new dehex copy/part s e
		new
	]

	if cs/1 = '- [
		cs/1:  charset "0123465798"						;-- digit
		cs/2:  charset "ABCDEF"							;-- hexa-upper
		cs/3:  charset "abcdef"							;-- hexa-lower
		cs/4:  union cs/1 cs/2							;-- hexa
		cs/5:  union cs/4 cs/3							;-- hexa-char
		cs/6:  charset {/\^^,[](){}"#%$@:;}				;-- not-word-char
		cs/7:  union union cs/6 cs/1 charset {'}		;-- not-word-1st
		cs/8:  charset {[](){}"@:;}						;-- not-file-char
		cs/9:  #"^""									;-- not-str-char
		cs/10: #"}"										;-- not-mstr-char
		cs/11: charset [#"^(40)" - #"^(5F)"]			;-- caret-char
		cs/12: charset [#"^(00)" - #"^(1F)"]			;-- non-printable-char
		cs/13: charset {^{"[]);}						;-- integer-end
		cs/14: charset " ^-^M"							;-- ws-ASCII, ASCII common whitespaces
		cs/15: charset [#"^(80)" - #"^(8A)"]			;-- ws-U+2k, Unicode spaces in the U+2000-U+200A range
		cs/16: charset [#"^(00)" - #"^(1F)"] 			;-- ASCII control characters

	]
	set [
		digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
		not-file-char not-str-char not-mstr-char caret-char
		non-printable-char integer-end ws-ASCII ws-U+2k control-char
	] cs

	;-- Whitespaces list from: http://en.wikipedia.org/wiki/Whitespace_character
	ws: [
		pos: #"^/" (
			if count? [
				line: line + 1
				;append/only lines to block! stack/tail?
			]
		)
		| ws-ASCII										;-- only the common whitespaces are matched
		| #"^(0085)"									;-- U+0085 (Newline)
		| #"^(00A0)"									;-- U+00A0 (No-break space)
		| #"^(1680)"									;-- U+1680 (Ogham space mark)
		| #"^(180E)"									;-- U+180E (Mongolian vowel separator)
		| ws-U+2k										;-- U+2000-U+200A range
		| #"^(2028)"									;-- U+2028 (Line separator)
		| #"^(2029)"									;-- U+2029 (Paragraph separator)
		| #"^(202F)"									;-- U+202F (Narrow no-break space)
		| #"^(205F)"									;-- U+205F (Medium mathematical space)
		| #"^(3000)"									;-- U+3000 (Ideographic space)
	]

	newline-char: [
		#"^/"
		| #"^(0085)"									;-- U+0085 (Newline)
		| #"^(2028)"									;-- U+2028 (Line separator)
		| #"^(2029)"									;-- U+2029 (Paragraph separator)
	]

	counted-newline: [pos: #"^/" (line: line + 1)]

	ws-no-count: [(count?: no) ws (count?: yes)]

	escaped-char: [
		"^^(" [
			[										;-- special case first
				"null" 	 (value: #"^(00)")
				| "back" (value: #"^(08)")
				| "tab"  (value: #"^(09)")
				| "line" (value: #"^(0A)")
				| "page" (value: #"^(0C)")
				| "esc"  (value: #"^(1B)")
				| "del"	 (value: #"^(7F)")
			]
			| pos: [2 6 hexa-char] e: (				;-- Unicode values allowed up to 10FFFFh
				value: trans-char pos e
			)
		] #")"
		| #"^^" [
			[
				#"/" 	(value: #"^/")
				| #"-"	(value: #"^-")
				| #"?" 	(value: #"^(del)")			;@@FIXME
				| #"^^" (value: #"^^")				;-- caret escaping case
				| #"{"	(value: #"{")
				| #"}"	(value: #"}")
				| #"^""	(value: #"^"")
			]
			| pos: caret-char (value: pos/1 - 64)
		]
	]

	char-rule: [
		{#"} s: [
			 escaped-char
			| ahead [non-printable-char | not-str-char] break
			| skip (value: s/1)
		] {"}
	]

	line-string: [
		{"} s: any [
			{^^"}
			| ahead [#"^"" | newline-char] break
			| escaped-char
			| skip
		]
		e: {"}
	]

	nested-curly-braces: [
		(cnt: 1)
		any [
			counted-newline
			| "^^{"
			| "^^}"
			| #"{" 	  (cnt: cnt + 1)
			| e: #"}" if (zero? cnt: cnt - 1) break
			| escaped-char
			| skip
		]
	]

	multiline-string: [#"{" s: nested-curly-braces]

	string-rule: [(type: string!) line-string | multiline-string]

	file-rule: [
		#"%" [
			line-string (process: trans-string type: file!)
			| s: any [ahead [not-file-char | ws-no-count] break | skip] e:
			  (process: trans-file type: file!)
		]
	]

	url-rule: [
		#":" not [integer-end | ws-no-count | end]
		any [#"@" | #":" | ahead [not-file-char | ws-no-count] break | skip] e:
		(type: url! trans-store stack do trans-file)
	]

	symbol-rule: [
		some [ahead [not-word-char | ws-no-count | control-char] break | skip] e:
	]

	begin-symbol-rule: [								;-- 1st char in symbols is restricted
		[not ahead [not-word-1st | ws-no-count | control-char]]
		symbol-rule
	]

	path-rule: [
		ahead slash (									;-- path detection barrier
			trans-push-path stack type					;-- create empty path
			trans-word stack copy/part s e word!		;-- push 1st path element
		)
		some [
			slash
			s: [
				integer-number-rule			(trans-store stack trans-integer s e)
				| begin-symbol-rule			(trans-word stack copy/part s e word!)
				| paren-rule
				| #":" s: begin-symbol-rule	(trans-word stack copy/part s e get-word!)
				;@@ add more datatypes here
			]
			opt [#":" (trans-set-path back tail stack)]
		] (trans-pop stack)
	]

	word-rule: 	[
		#"%" ws-no-count (trans-word stack "%" word!)	;-- special case for remainder op!
		| s: begin-symbol-rule (type: word!) [
				url-rule
				| path-rule								;-- path matched
				| opt [#":" (type: set-word!)]
				  (trans-word stack copy/part s e type)	;-- word or set-word matched
		  ]
	]

	get-word-rule: [
		#":" (type: get-word!) s: begin-symbol-rule [
			path-rule (type: get-path!)
			| (trans-word stack copy/part s e type)		;-- get-word matched
		]
	]

	lit-word-rule: [
		#"'" (type: lit-word!) s: begin-symbol-rule [
			path-rule (type: lit-path!)					;-- path matched
			| (trans-word stack copy/part s e type)		;-- lit-word matched
		]
	]

	issue-rule: [
		#"#" (type: issue!) s: symbol-rule
		(trans-word stack copy/part s e type)
	]

	refinement-rule: [
		slash (type: refinement!) s: symbol-rule
		(trans-word stack copy/part s e type)
	]

	slash-rule: [s: [slash opt slash] e:]

	hexa-rule: [2 8 hexa e: #"h"]

	integer-number-rule: [
		opt [#"-" | #"+"] digit any [digit | #"'" digit] e:
	]

	integer-rule: [
		integer-number-rule
		ahead [integer-end | ws-no-count | end]
	]

	block-rule: [
		#"[" (append/only stack make block! 4)
		any-value
		#"]" (trans-pop stack)
	]

	paren-rule: [
		#"(" (append/only stack make paren! 4)
		any-value
		#")" (trans-pop stack)
	]

	escaped-rule: [
		"#[" pos: any ws [
			  "true"  			(value: true)
			| "false" 			(value: false)
			| [
				"none!"			(value: none!)
				| "logic!"		(value: logic!)
				| "block!"		(value: block!)
				| "integer!"	(value: integer!)
				| "word!"		(value: word!)
				| "set-word!"	(value: set-word!)
				| "get-word!"	(value: get-word!)
				| "lit-word!"	(value: lit-word!)
				| "refinement!"	(value: refinement!)
				;| "binary!"	(value: binary!)
				| "string!"		(value: string!)
				| "char!"		(value: char!)
				| "bitset!"		(value: bitset!)
				| "path!"		(value: path!)
				| "set-path!"	(value: set-path!)
				| "lit-path!"	(value: lit-path!)
				| "get-path!"	(value: get-path!)
				| "native!"		(value: native!)
				| "action!"		(value: action!)
				| "op!"			(value: op!)
				| "issue!"		(value: issue!)
				| "paren!"		(value: paren!)
				| "function!"	(value: function!)
				| "routine!"	(value: routine!)
			]
			| "none" 			(value: none)
		] pos: any ws #"]"
	]

	comment-rule: [#";" [to lf | to end]]

	wrong-delimiters: [
		pos: [
			  #"]" (value: #"[") | #")" (value: #"(")
			| #"[" (value: #"]") | #"(" (value: #")")
		] :pos
		(print ["missing matching" value])
	]

	literal-value: [
		pos: (e: none) s: [
			comment-rule
			| escaped-rule		(trans-store stack value)
			| integer-rule		if (value: trans-integer s e ) (trans-store stack value)
			| hexa-rule			(trans-store stack trans-hexa s e)
			| word-rule
			| lit-word-rule
			| get-word-rule
			| slash-rule		(trans-word stack copy/part s e word!)
			| refinement-rule
			| file-rule			(trans-store stack value: do process)
			| char-rule			(trans-store stack value)
			| issue-rule
			| block-rule
			| paren-rule
			| string-rule		(trans-store stack do trans-string)
			;| binary-rule	  	(stack/push load-binary s e)
		]
	]

	any-value: [pos: any [literal-value | ws]]

	red-rules: [any-value opt wrong-delimiters]

	unless either part [
		parse/case/part src red-rules length
	][
		parse/case src red-rules
	][
		print ["*** Syntax Error: invalid Red value at:" copy/part pos 20]
	]
	stack/1
]

Red [
	Title:   "Red runtime lexer"
	Author:  "Nenad Rakocevic"
	File: 	 %lexer.red
	Tabs:	 4
	Rights:  "Copyright (C) 2014 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
	}
]

trans-integer: routine [
	start [string!]
	end	  [string!]
	/local
		c	 [integer!]
		n	 [integer!]
		m	 [integer!]
		len  [integer!]
		p	 [byte-ptr!]
		neg? [logic!]
][
	str:  GET_BUFFER(start)
	unit: GET_UNIT(str)
	p:	  string/rs-head start
	len:  end/head - start/head
	neg?: no

	c: string/get-char p unit
	if any [
		c = as-integer #"+"
		c = as-integer #"-"
	][
		neg?: c = as-integer #"-"
		p: p + unit
		len: len - 1
	]
	n: 0
	until [
		c: (string/get-char p unit) - #"0"

		m: n * 10
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		if all [n = 2147483640 c = 8][
			integer/box 80000000h						;-- special exit trap for -2147483648
			exit
		]

		m: n + c
		if m < n [SET_RETURN(none-value) exit]			;-- return NONE on overflow
		n: m

		p: p + unit
		len: len - 1
		zero? len
	]
	integer/box either neg? [0 - n][n]
]

trans-hexa: routine [
	start	[string!]
	end		[string!]
	return: [integer!]
	/local
		s	  [series!]
		unit  [integer!]
		p	  [byte-ptr!]
		head  [byte-ptr!]
		p4	  [int-ptr!]
		n	  [integer!]
		power [integer!]
		cp	  [byte!]
][
	s: GET_BUFFER(start)
	unit: GET_UNIT(s)

	p: (string/rs-head end) - unit
	head: string/rs-head start

	n: 0
	power: 0
	while [p >= head][
		cp: switch unit [
			Latin1 [p/value]
			UCS-2  [as-byte ((as-integer p/2) << 8 + p/1)]
			UCS-4  [p4: as int-ptr! p as-byte p4/value]
		]
		if cp <> #"0" [
			case [
				all [#"0" <= cp cp <= #"9"][cp: cp - #"0"]
				all [#"A" <= cp cp <= #"F"][cp: cp - #"A" + 10]
				all [#"a" <= cp cp <= #"f"][cp: cp - #"a" + 10]
			]
			n: n + ((as-integer cp) << power)
		]
		power: power + 4
		p: p - unit
	]
	n
]

trans-char: routine [
	start	[string!]
	end		[string!]
	/local
		n	  [integer!]
		value [red-value!]
][
	n: trans-hexa start end
	value: as red-value! integer/box n
	set-type value TYPE_CHAR
]

trans-push-path: routine [
	stack [block!]
	type  [datatype!]
	/local
		path [red-path!]
][
	path: as red-path! block/make-at as red-block! ALLOC_TAIL(stack) 4
	path/header: switch type/value [
		TYPE_GET_WORD [TYPE_GET_PATH]
		TYPE_LIT_WORD [TYPE_LIT_PATH]
		default [TYPE_PATH]
	]
]

trans-set-path: routine [
	stack [block!]
	/local
		path [red-path!]
][
	path: as red-path! block/pick stack 1 null
	set-type as red-value! path TYPE_SET_PATH
]

trans-make-word: routine [
	src   [string!]
	type  [datatype!]
][
	set-type
		as red-value! word/box (symbol/make-alt src) ;-- word/box puts it in stack/arguments
		type/value
]

trans-word: func [
	stack [block!]
	src   [string!]
	type  [datatype!]
][
	trans-store stack trans-make-word src type
]

trans-pop: function [stack [block!]][
	value: last stack
	remove back tail stack

	either any [1 < length? stack head? stack/1][
		append/only last stack :value
	][
		pos: back tail stack							;-- root storage and offset-ed series (/into option)
		pos/1: insert/only last stack :value
	]
]

trans-store: function [stack [block!] value][
	either any [1 < length? stack head? stack/1][
		append last stack value
	][
		pos: back tail stack							;-- root storage and offset-ed series (/into option)
		pos/1: insert last stack value
	]
]

transcode: function [
	src	[string!]
	dst	[block! none!]
	/part
		length [integer! string!]
	return: [block!]
	/local
		new s e c hex pos value cnt type process
		digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
		not-file-char not-str-char not-mstr-char caret-char
		non-printable-char integer-end ws-ASCII ws-U+2k control-char
][
	cs:		[- - - - - - - - - - - - - - - -]			;-- memoized bitsets
	stack:	clear []
	count?:	yes											;-- if TRUE, lines counter is enabled
	line: 	1

	append/only stack any [dst make block! 4]

	trans-string: [
		new: make type (index? e) - index? s
		parse/case copy/part s e [						;@@ add /part option to parse!
			any [
				escaped-char (append new value)
				| #"^^"									;-- trash single caret chars
				| set c skip (append new c)
			]
		]
		new
	]

	trans-file: [
		new: make type (index? e) - index? s
		append new dehex copy/part s e
		new
	]

	if cs/1 = '- [
		cs/1:  charset "0123465798"						;-- digit
		cs/2:  charset "ABCDEF"							;-- hexa-upper
		cs/3:  charset "abcdef"							;-- hexa-lower
		cs/4:  union cs/1 cs/2							;-- hexa
		cs/5:  union cs/4 cs/3							;-- hexa-char
		cs/6:  charset {/\^^,[](){}"#%$@:;}				;-- not-word-char
		cs/7:  union union cs/6 cs/1 charset {'}		;-- not-word-1st
		cs/8:  charset {[](){}"@:;}						;-- not-file-char
		cs/9:  #"^""									;-- not-str-char
		cs/10: #"}"										;-- not-mstr-char
		cs/11: charset [#"^(40)" - #"^(5F)"]			;-- caret-char
		cs/12: charset [#"^(00)" - #"^(1F)"]			;-- non-printable-char
		cs/13: charset {^{"[]);}						;-- integer-end
		cs/14: charset " ^-^M"							;-- ws-ASCII, ASCII common whitespaces
		cs/15: charset [#"^(80)" - #"^(8A)"]			;-- ws-U+2k, Unicode spaces in the U+2000-U+200A range
		cs/16: charset [#"^(00)" - #"^(1F)"] 			;-- ASCII control characters

	]
	set [
		digit hexa-upper hexa-lower hexa hexa-char not-word-char not-word-1st
		not-file-char not-str-char not-mstr-char caret-char
		non-printable-char integer-end ws-ASCII ws-U+2k control-char
	] cs

	;-- Whitespaces list from: http://en.wikipedia.org/wiki/Whitespace_character
	ws: [
		pos: #"^/" (
			if count? [
				line: line + 1
				;append/only lines to block! stack/tail?
			]
		)
		| ws-ASCII										;-- only the common whitespaces are matched
		| #"^(0085)"									;-- U+0085 (Newline)
		| #"^(00A0)"									;-- U+00A0 (No-break space)
		| #"^(1680)"									;-- U+1680 (Ogham space mark)
		| #"^(180E)"									;-- U+180E (Mongolian vowel separator)
		| ws-U+2k										;-- U+2000-U+200A range
		| #"^(2028)"									;-- U+2028 (Line separator)
		| #"^(2029)"									;-- U+2029 (Paragraph separator)
		| #"^(202F)"									;-- U+202F (Narrow no-break space)
		| #"^(205F)"									;-- U+205F (Medium mathematical space)
		| #"^(3000)"									;-- U+3000 (Ideographic space)
	]

	newline-char: [
		#"^/"
		| #"^(0085)"									;-- U+0085 (Newline)
		| #"^(2028)"									;-- U+2028 (Line separator)
		| #"^(2029)"									;-- U+2029 (Paragraph separator)
	]

	counted-newline: [pos: #"^/" (line: line + 1)]

	ws-no-count: [(count?: no) ws (count?: yes)]

	escaped-char: [
		"^^(" [
			[										;-- special case first
				"null" 	 (value: #"^(00)")
				| "back" (value: #"^(08)")
				| "tab"  (value: #"^(09)")
				| "line" (value: #"^(0A)")
				| "page" (value: #"^(0C)")
				| "esc"  (value: #"^(1B)")
				| "del"	 (value: #"^(7F)")
			]
			| pos: [2 6 hexa-char] e: (				;-- Unicode values allowed up to 10FFFFh
				value: trans-char pos e
			)
		] #")"
		| #"^^" [
			[
				#"/" 	(value: #"^/")
				| #"-"	(value: #"^-")
				| #"?" 	(value: #"^(del)")			;@@FIXME
				| #"^^" (value: #"^^")				;-- caret escaping case
				| #"{"	(value: #"{")
				| #"}"	(value: #"}")
				| #"^""	(value: #"^"")
			]
			| pos: caret-char (value: pos/1 - 64)
		]
	]

	char-rule: [
		{#"} s: [
			 escaped-char
			| ahead [non-printable-char | not-str-char] break
			| skip (value: s/1)
		] {"}
	]

	line-string: [
		{"} s: any [
			{^^"}
			| ahead [#"^"" | newline-char] break
			| escaped-char
			| skip
		]
		e: {"}
	]

	nested-curly-braces: [
		(cnt: 1)
		any [
			counted-newline
			| "^^{"
			| "^^}"
			| #"{" 	  (cnt: cnt + 1)
			| e: #"}" if (zero? cnt: cnt - 1) break
			| escaped-char
			| skip
		]
	]

	multiline-string: [#"{" s: nested-curly-braces]

	string-rule: [(type: string!) line-string | multiline-string]

	file-rule: [
		#"%" [
			line-string (process: trans-string type: file!)
			| s: any [ahead [not-file-char | ws-no-count] break | skip] e:
			  (process: trans-file type: file!)
		]
	]

	url-rule: [
		#":" not [integer-end | ws-no-count | end]
		any [#"@" | #":" | ahead [not-file-char | ws-no-count] break | skip] e:
		(type: url! trans-store stack do trans-file)
	]

	symbol-rule: [
		some [ahead [not-word-char | ws-no-count | control-char] break | skip] e:
	]

	begin-symbol-rule: [								;-- 1st char in symbols is restricted
		[not ahead [not-word-1st | ws-no-count | control-char]]
		symbol-rule
	]

	path-rule: [
		ahead slash (									;-- path detection barrier
			trans-push-path stack type					;-- create empty path
			trans-word stack copy/part s e type			;-- push 1st path element
		)
		some [
			slash
			s: [
				integer-number-rule			(trans-store stack trans-integer s e)
				| begin-symbol-rule			(trans-word stack copy/part s e word!)
				| paren-rule
				| #":" s: begin-symbol-rule	(trans-word stack copy/part s e get-word!)
				;@@ add more datatypes here
			]
			opt [#":" (trans-set-path back tail stack)]
		] (trans-pop stack)
	]

	word-rule: 	[
		#"%" ws-no-count (trans-word stack "%" word!)	;-- special case for remainder op!
		| s: begin-symbol-rule (type: word!) [
				url-rule
				| path-rule								;-- path matched
				| opt [#":" (type: set-word!)]
				  (trans-word stack copy/part s e type)	;-- word or set-word matched
		  ]
	]

	get-word-rule: [
		#":" (type: get-word!) s: begin-symbol-rule [
			path-rule (type: get-path!)
			| (trans-word stack copy/part s e type)		;-- get-word matched
		]
	]

	lit-word-rule: [
		#"'" (type: lit-word!) s: begin-symbol-rule [
			path-rule (type: lit-path!)					;-- path matched
			| (trans-word stack copy/part s e type)		;-- lit-word matched
		]
	]

	issue-rule: [
		#"#" (type: issue!) s: symbol-rule
		(trans-word stack copy/part s e type)
	]

	refinement-rule: [
		slash (type: refinement!) s: symbol-rule
		(trans-word stack copy/part s e type)
	]

	slash-rule: [s: [slash opt slash] e:]

	hexa-rule: [2 8 hexa e: #"h"]

	integer-number-rule: [
		opt [#"-" | #"+"] digit any [digit | #"'" digit] e:
	]

	integer-rule: [
		integer-number-rule
		ahead [integer-end | ws-no-count | end]
	]

	block-rule: [
		#"[" (append/only stack make block! 4)
		any-value
		#"]" (trans-pop stack)
	]

	paren-rule: [
		#"(" (append/only stack make paren! 4)
		any-value
		#")" (trans-pop stack)
	]

	escaped-rule: [
		"#[" pos: any ws [
			  "true"  			(value: true)
			| "false" 			(value: false)
			| [
				"none!"			(value: none!)
				| "logic!"		(value: logic!)
				| "block!"		(value: block!)
				| "integer!"	(value: integer!)
				| "word!"		(value: word!)
				| "set-word!"	(value: set-word!)
				| "get-word!"	(value: get-word!)
				| "lit-word!"	(value: lit-word!)
				| "refinement!"	(value: refinement!)
				;| "binary!"	(value: binary!)
				| "string!"		(value: string!)
				| "char!"		(value: char!)
				| "bitset!"		(value: bitset!)
				| "path!"		(value: path!)
				| "set-path!"	(value: set-path!)
				| "lit-path!"	(value: lit-path!)
				| "get-path!"	(value: get-path!)
				| "native!"		(value: native!)
				| "action!"		(value: action!)
				| "op!"			(value: op!)
				| "issue!"		(value: issue!)
				| "paren!"		(value: paren!)
				| "function!"	(value: function!)
				| "routine!"	(value: routine!)
			]
			| "none" 			(value: none)
		] pos: any ws #"]"
	]

	comment-rule: [#";" [to lf | to end]]

	wrong-delimiters: [
		pos: [
			  #"]" (value: #"[") | #")" (value: #"(")
			| #"[" (value: #"]") | #"(" (value: #")")
		] :pos
		(print ["missing matching" value])
	]

	literal-value: [
		pos: (e: none) s: [
			comment-rule
			| escaped-rule		(trans-store stack value)
			| integer-rule		if (value: trans-integer s e ) (trans-store stack value)
			| hexa-rule			(trans-store stack trans-hexa s e)
			| word-rule
			| lit-word-rule
			| get-word-rule
			| slash-rule		(trans-word stack copy/part s e word!)
			| refinement-rule
			| file-rule			(trans-store stack value: do process)
			| char-rule			(trans-store stack value)
			| issue-rule
			| block-rule
			| paren-rule
			| string-rule		(trans-store stack do trans-string)
			;| binary-rule	  	(stack/push load-binary s e)
		]
	]

	any-value: [pos: any [literal-value | ws]]

	red-rules: [any-value opt wrong-delimiters]

	unless either part [
		parse/case/part src red-rules length
	][
		parse/case src red-rules
	][
		print ["*** Syntax Error: invalid Red value at:" copy/part pos 20]
	]
	stack/1
]


TESTS: Additional SWITCH tests.

TESTS: Additional SWITCH tests.

Red/System [
	Title:   "Red/System switch function test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %switch-test.reds
	Rights:  "Copyright (C) 2011, 2012 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "switch"

===start-group=== "switch basics"

	--test-- "switch-basic-1"
	ci: 0
	cia: 1
	switch ci [0 [] default [0]]
	--assert cia = 1

	--test-- "switch-basic-2"
	ci: 1
	cia: 2
	switch ci [1 [cia: 2]]
	--assert cia = 2

	--test-- "switch-basic-3"
	ci: 1
	cia: 2
	switch ci [0 [] default [cia: 3]]
	--assert cia = 3

	--test-- "switch-basic-4"
	ci: 0
	cia: 2
	switch ci [1 [cia: 0] default [cia: 3]]
	--assert cia = 3

	--test-- "switch-basic-5"
	ci: 99
	cia: 2
	switch ci [1 [cia: 2] default [cia: 3]]
	--assert cia = 3

	--test-- "switch-basic-6"
	ci: 0
	cia: 1
	cia: switch ci [1 [0] default [2]]
	--assert cia = 2

	--test-- "switch-basic-7"
	ci: 1
	cia: 2
	cia: switch ci [1 [3]]
	--assert cia = 3

	--test-- "switch-basic-8"
	ci: 8
	cia: 2
	switch ci [8 [switch ci [8 [cia: 3] default [cia: 4]]]]
	--assert cia = 3

	--test-- "switch-basic-9"
	ci:  1
	cia: 2
	cia: switch ci [1 [switch ci [1 [3] default [4]]]]
	--assert cia = 3

	--test-- "switch-basic-10"
	ci:  8
	cia: 2
	cia: switch ci [8 [case [ci = 8 [3] true [4]]]]
	--assert cia = 3

===end-group===

===start-group=== "switch integer!"

#define switch-int-1 [switch ci [ 1 [cia: 1] 2 [cia: 2] default [cia: 3]]]

	--test-- "switch-int-1"
	  ci: 1
	  cia: 0
	  switch-int-1
	--assert 1 = cia

	--test-- "switch-int-2"
	  ci: 2
	  cia: 0
	  switch-int-1
	--assert 2 = cia

	--test-- "switch-int-3"
	  ci: 3
	  cia: 0
	  switch-int-1
	--assert 3 = cia

	--test-- "switch-int-4"
	  ci: 9
	  cia: 0
	  switch-int-1
	--assert 3 = cia

	#define switch-int-2 [switch ci [1 [1] 2 [2] default [3]]]

	--test-- "switch-int-5"
	  ci: 1
	--assert 1 = switch-int-2

	--test-- "switch-int-6"
	  ci: 1
	  cres: switch-int-2
	--assert 1 = cres

	--test-- "switch-int-7"
	  ci: 2
	--assert 2 = switch-int-2

	--test-- "switch-int-8"
	  ci: 2
	  cres: switch-int-2
	--assert 2 = cres

	--test-- "switch-int-9"
	  ci: 3
	--assert 3 = switch-int-2

	--test-- "switch-int-10"
	  ci: 3
	  cres: switch-int-2
	--assert 3 = cres

	--test-- "switch-int-11"
	  ci: 10
	--assert 3 = switch-int-2

	--test-- "switch-int-12"
	  ci: 10
	  cres: switch-int-2
	--assert 3 = cres

	#define switch-int-3 [switch ci [1 [cia: 1] 2 [cia: 2] default [cia: 3]] ]

	--test-- "switch-int-13"
	  ci: 1
	  cia: 0
	--assert 1 = switch-int-3

	--test-- "switch-int-14"
	  ci: 1
	  cia: 0
	  cres: switch-int-3
	--assert 1 = cres

	--test-- "switch-int-15"
	  ci: 2
	  cia: 0
	--assert 2 = switch-int-3

	--test-- "switch-int-16"
	  ci: 2
	  cia: 0
	  cres: switch-int-3
	--assert 2 = cres

	--test-- "switch-int-17"
	  ci: 3
	  cia: 0
	--assert 3 = switch-int-3

	--test-- "switch-int-18"
	  ci: 3
	  cia: 0
	  cres: switch-int-3
	--assert 3 = cres

	--test-- "switch-int-19"
	  ci: 9
	  cia: 0
	--assert 3 = switch-int-3

	--test-- "switch-int-20"
	  ci: 9
	  cia: 0
	  cres: switch-int-3
	--assert 3 = cres

===end-group===

===start-group=== "switch byte!"

#define switch-byte-1 [switch cb [#"1" [cba: #"1"] #"2" [cba: #"2"] default [cba: #"3"]]]

	--test-- "switch-byte-1"
	  cb: #"1"
	  cba: #"0"
	  switch-byte-1
	--assert #"1" = cba

	--test-- "switch-byte-2"
	  cb: #"2"
	  cba: #"0"
	  switch-byte-1
	--assert #"2" = cba

	--test-- "switch-byte-3"
	  cb: #"3"
	  cba: #"0"
	  switch-byte-1
	--assert #"3" = cba

	--test-- "switch-byte-4"
	  cb: #"9"
	  cba: #"0"
	  switch-byte-1
	--assert #"3" = cba

	#define switch-byte-2 [switch cb [#"1" [#"1"] #"2" [#"2"] default [#"3"]]]

	--test-- "switch-byte-5"
	  cb: #"1"
	--assert #"1" = switch-byte-2

	--test-- "switch-byte-6"
	  cb: #"1"
	  cbres: switch-byte-2
	--assert #"1" = cbres

	--test-- "switch-byte-7"
	  cb: #"2"
	--assert #"2" = switch-byte-2

	--test-- "switch-byte-8"
	  cb: #"2"
	  cbres: switch-byte-2
	--assert #"2" = cbres

	--test-- "switch-byte-9"
	  cb: #"3"
	--assert #"3" = switch-byte-2

	--test-- "switch-byte-10"
	  cb: #"3"
	  cbres: switch-byte-2
	--assert #"3" = cbres

	--test-- "switch-byte-11"
	  cb: #"9"
	--assert #"3" = switch-byte-2

	--test-- "switch-byte-12"
	  cb: #"9"
	  cbres: switch-byte-2
	--assert #"3" = cbres

	#define switch-byte-3 [switch cb [#"1" [cba: #"1"] #"2" [cba: #"2"] default [cba: #"3"]] ]

	--test-- "switch-byte-13"
	  cb: #"1"
	  cba: #"0"
	--assert #"1" = switch-byte-3

	--test-- "switch-byte-14"
	  cb: #"1"
	  cba: #"0"
	  cbres: switch-byte-3
	--assert #"1" = cbres

	--test-- "switch-byte-15"
	  cb: #"2"
	  cba: #"0"
	--assert #"2" = switch-byte-3

	--test-- "switch-byte-16"
	  cb: #"2"
	  cba: #"0"
	  cbres: switch-byte-3
	--assert #"2" = cbres

	--test-- "switch-byte-17"
	  cb: #"3"
	  cba: #"0"
	--assert #"3" = switch-byte-3

	--test-- "switch-byte-18"
	  cb: #"3"
	  cba: #"0"
	  cbres: switch-byte-3
	--assert #"3" = cbres

	--test-- "switch-byte-19"
	  cb: #"9"
	  cba: #"0"
	--assert #"3" = switch-byte-3

	--test-- "switch-byte-20"
	  cb: #"9"
	  cba: #"0"
	  cbres: switch-byte-3
	--assert #"3" = cbres

===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System switch function test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %switch-test.reds
	Rights:  "Copyright (C) 2011, 2012 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

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

~~~start-file~~~ "switch"

===start-group=== "switch integer!"

#define switch-int-1 [switch ci [ 1 [cia: 1] 2 [cia: 2] default [cia: 3]]]

	--test-- "switch-int-1"
	  ci: 1
	  cia: 0
	  switch-int-1
	--assert 1 = cia

	--test-- "switch-int-2"
	  ci: 2
	  cia: 0
	  switch-int-1
	--assert 2 = cia

	--test-- "switch-int-3"
	  ci: 3
	  cia: 0
	  switch-int-1
	--assert 3 = cia

	--test-- "switch-int-4"
	  ci: 9
	  cia: 0
	  switch-int-1
	--assert 3 = cia

	#define switch-int-2 [switch ci [1 [1] 2 [2] default [3]]]

	--test-- "switch-int-5"
	  ci: 1
	--assert 1 = switch-int-2

	--test-- "switch-int-6"
	  ci: 1
	  cres: switch-int-2
	--assert 1 = cres

	--test-- "switch-int-7"
	  ci: 2
	--assert 2 = switch-int-2

	--test-- "switch-int-8"
	  ci: 2
	  cres: switch-int-2
	--assert 2 = cres

	--test-- "switch-int-9"
	  ci: 3
	--assert 3 = switch-int-2

	--test-- "switch-int-10"
	  ci: 3
	  cres: switch-int-2
	--assert 3 = cres

	--test-- "switch-int-11"
	  ci: 10
	--assert 3 = switch-int-2

	--test-- "switch-int-12"
	  ci: 10
	  cres: switch-int-2
	--assert 3 = cres

	#define switch-int-3 [switch ci [1 [cia: 1] 2 [cia: 2] default [cia: 3]] ]

	--test-- "switch-int-13"
	  ci: 1
	  cia: 0
	--assert 1 = switch-int-3

	--test-- "switch-int-14"
	  ci: 1
	  cia: 0
	  cres: switch-int-3
	--assert 1 = cres

	--test-- "switch-int-15"
	  ci: 2
	  cia: 0
	--assert 2 = switch-int-3

	--test-- "switch-int-16"
	  ci: 2
	  cia: 0
	  cres: switch-int-3
	--assert 2 = cres

	--test-- "switch-int-17"
	  ci: 3
	  cia: 0
	--assert 3 = switch-int-3

	--test-- "switch-int-18"
	  ci: 3
	  cia: 0
	  cres: switch-int-3
	--assert 3 = cres

	--test-- "switch-int-19"
	  ci: 9
	  cia: 0
	--assert 3 = switch-int-3

	--test-- "switch-int-20"
	  ci: 9
	  cia: 0
	  cres: switch-int-3
	--assert 3 = cres

===end-group===

===start-group=== "switch byte!"

#define switch-byte-1 [switch cb [#"1" [cba: #"1"] #"2" [cba: #"2"] default [cba: #"3"]]]

	--test-- "switch-byte-1"
	  cb: #"1"
	  cba: #"0"
	  switch-byte-1
	--assert #"1" = cba

	--test-- "switch-byte-2"
	  cb: #"2"
	  cba: #"0"
	  switch-byte-1
	--assert #"2" = cba

	--test-- "switch-byte-3"
	  cb: #"3"
	  cba: #"0"
	  switch-byte-1
	--assert #"3" = cba

	--test-- "switch-byte-4"
	  cb: #"9"
	  cba: #"0"
	  switch-byte-1
	--assert #"3" = cba

	#define switch-byte-2 [switch cb [#"1" [#"1"] #"2" [#"2"] default [#"3"]]]

	--test-- "switch-byte-5"
	  cb: #"1"
	--assert #"1" = switch-byte-2

	--test-- "switch-byte-6"
	  cb: #"1"
	  cbres: switch-byte-2
	--assert #"1" = cbres

	--test-- "switch-byte-7"
	  cb: #"2"
	--assert #"2" = switch-byte-2

	--test-- "switch-byte-8"
	  cb: #"2"
	  cbres: switch-byte-2
	--assert #"2" = cbres

	--test-- "switch-byte-9"
	  cb: #"3"
	--assert #"3" = switch-byte-2

	--test-- "switch-byte-10"
	  cb: #"3"
	  cbres: switch-byte-2
	--assert #"3" = cbres

	--test-- "switch-byte-11"
	  cb: #"9"
	--assert #"3" = switch-byte-2

	--test-- "switch-byte-12"
	  cb: #"9"
	  cbres: switch-byte-2
	--assert #"3" = cbres

	#define switch-byte-3 [switch cb [#"1" [cba: #"1"] #"2" [cba: #"2"] default [cba: #"3"]] ]

	--test-- "switch-byte-13"
	  cb: #"1"
	  cba: #"0"
	--assert #"1" = switch-byte-3

	--test-- "switch-byte-14"
	  cb: #"1"
	  cba: #"0"
	  cbres: switch-byte-3
	--assert #"1" = cbres

	--test-- "switch-byte-15"
	  cb: #"2"
	  cba: #"0"
	--assert #"2" = switch-byte-3

	--test-- "switch-byte-16"
	  cb: #"2"
	  cba: #"0"
	  cbres: switch-byte-3
	--assert #"2" = cbres

	--test-- "switch-byte-17"
	  cb: #"3"
	  cba: #"0"
	--assert #"3" = switch-byte-3

	--test-- "switch-byte-18"
	  cb: #"3"
	  cba: #"0"
	  cbres: switch-byte-3
	--assert #"3" = cbres

	--test-- "switch-byte-19"
	  cb: #"9"
	  cba: #"0"
	--assert #"3" = switch-byte-3

	--test-- "switch-byte-20"
	  cb: #"9"
	  cba: #"0"
	  cbres: switch-byte-3
	--assert #"3" = cbres

===end-group===

~~~end-file~~~


minor tidying up

minor tidying up

% 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
% Sean-To-do: figure out why reverse
% Arthur answer: the for-each loop builds up the result list r by putting
% items on its front and that reverses the original input, so the reverese
% here restores it.
    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;
    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;
% 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 the 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
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);
  begin
    d := subla(b, c);
    if zerop reval(car d) then return t
    else return nil;
  end;

symbolic procedure check_non_zero_q(c, b);
  'fail;
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);
  'fail;
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), 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)^(-2); 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
% Sean-To-do: figure out why reverse
% Arthur answer: the for-each loop builds up the result list r by putting
% items on its front and that reverses the original input, so the reverese
% here restores it.
    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;
    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;
% 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 the 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
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);
  begin
    d := subla(b, c);
    if zerop reval(car d) then return t
    else return nil;
  end;

symbolic procedure check_non_zero_q(c, b);
  'fail;
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);
  'fail;
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 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);
  begin
    scalar w;
    if eqcar(caddr car lpattern, '!_ ) then <<
%      princ "Attempting to add exponent 1.";
      w := trymatch(list('expt, car lu, 1), car lpattern, env);
      if w = 'fail then return 'fail
      else return trymatchlist(cdr lu, cdr lpattern, w);
    >>
    else return 'fail;
  end;

symbolic procedure trymatch_times(lu, lpattern, env);
  begin
    scalar w;
    if eqcar(cadr car lpattern, '!_!. ) then <<
%      princ "Attempting to add coefficient/times 1.";
      w := trymatch(list('times, 1, car lu), car lpattern, env);
      if w = 'fail then return 'fail
      else return trymatchlist(cdr lu, cdr lpattern, w);
      >>
    else return 'fail;
  end;

%======================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), 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)^(-2); 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;