FIX: rounding does not correct when add float to integer! vector

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

vector: context [
	verbose: 0

	rs-length?: func [
		vec 	[red-vector!]
		return: [integer!]
	][
		string/get-length as red-string! vec no
	]

	rs-skip: func [
		vec 	[red-vector!]
		len		[integer!]
		return: [logic!]
	][
		string/rs-skip as red-string! vec len
	]

	rs-next: func [
		vec 	[red-vector!]
		return: [logic!]
		/local
			s [series!]
	][
		rs-skip vec 1
	]

	rs-head: func [
		vec	    [red-vector!]
		return: [byte-ptr!]
		/local
			s [series!]
	][
		s: GET_BUFFER(vec)
		(as byte-ptr! s/offset) + (vec/head << (GET_UNIT(s) >> 1))
	]

	rs-tail: func [
		vec	    [red-vector!]
		return: [byte-ptr!]
		/local
			s [series!]
	][
		s: GET_BUFFER(vec)
		as byte-ptr! s/tail
	]

	rs-tail?: func [
		vec	    [red-vector!]
		return: [logic!]
		/local
			s [series!]
	][
		s: GET_BUFFER(vec)
		(as byte-ptr! s/offset) + (vec/head << (GET_UNIT(s) >> 1)) >= as byte-ptr! s/tail
	]

	rs-clear: func [
		vec [red-vector!]
		/local
			s [series!]
	][
		s: GET_BUFFER(vec)
		s/tail: as cell! (as byte-ptr! s/offset) + (vec/head << (GET_UNIT(s) >> 1))
	]

	rs-append-int: func [
		vec		[red-vector!]
		n		[integer!]
		/local
			s	 [series!]
			p	 [byte-ptr!]
			p4	 [int-ptr!]
	][
		s: GET_BUFFER(vec)
		p: alloc-tail-unit s 4
		p4: as int-ptr! p
		p4/value: n
	]

	rs-append: func [
		vec		[red-vector!]
		value	[red-value!]
		return: [red-value!]
		/local
			s	 [series!]
			p	 [byte-ptr!]
			unit [integer!]
	][
		if vec/type <> TYPE_OF(value) [
			fire [TO_ERROR(script invalid-arg) value]
		]

		assert TYPE_OF(value) = vec/type
		s: GET_BUFFER(vec)
		unit: GET_UNIT(s)
		p: alloc-tail-unit s either unit = 6 [8][unit]
		set-value p value unit
		value
	]

	rs-insert: func [
		vec		[red-vector!]
		offset	[integer!]								;-- offset from head in elements
		value	[red-value!]
		return: [series!]
		/local
			s	  [series!]
			p	  [byte-ptr!]
			unit  [integer!]
			unit2 [integer!]
	][
		if vec/type <> TYPE_OF(value) [
			fire [TO_ERROR(script invalid-arg) value]
		]

		s: GET_BUFFER(vec)
		unit: GET_UNIT(s)
		unit2: either unit = 6 [8][unit]

		if ((as byte-ptr! s/tail) + unit2) > ((as byte-ptr! s + 1) + s/size) [
			s: expand-series s 0
		]
		p: (as byte-ptr! s/offset) + (offset << (unit >> 1))

		move-memory										;-- make space
			p + unit2
			p
			as-integer (as byte-ptr! s/tail) - p

		s/tail: as cell! (as byte-ptr! s/tail) + unit2

		set-value p value unit
		s
	]

	get-value-int: func [
		p		[int-ptr!]
		unit	[integer!]
		return: [integer!]
	][
		switch unit [
			1 [p/value and FFh]
			2 [p/value and FFFFh]
			4 [p/value]
		]
	]

	get-value-float: func [
		p		[byte-ptr!]
		unit	[integer!]
		return: [float!]
		/local
			pf	 [pointer! [float!]]
			pf32 [pointer! [float32!]]
	][
		either unit = 4 [
			pf32: as pointer! [float32!] p
			as-float pf32/value
		][
			pf: as pointer! [float!] p
			pf/value
		]
	]

	get-value: func [
		p		[byte-ptr!]
		unit	[integer!]
		type	[integer!]
		return: [red-value!]
		/local
			int    [red-integer!]
			float  [red-float!]
	][
		switch type [
			TYPE_CHAR
			TYPE_INTEGER [
				int: as red-integer! stack/push*
				int/header: type
				int/value: get-value-int as int-ptr! p unit
				as red-value! int
			]
			TYPE_FLOAT [
				float: as red-float! stack/push*
				float/header: TYPE_FLOAT
				float/value: get-value-float p unit
				as red-value! float
			]
		]
	]

	set-value: func [
		p		[byte-ptr!]
		value	[red-value!]
		unit	[integer!]
		/local
			int  [red-integer!]
			f	 [red-float!]
			p4	 [int-ptr!]
			pf	 [pointer! [float!]]
			pf32 [pointer! [float32!]]
	][
		switch TYPE_OF(value) [
			TYPE_CHAR
			TYPE_INTEGER [ 			;-- char! and integer! structs are overlapping
				int: as red-integer! value
				p4: as int-ptr! p
				p4/value: switch unit [
					1 [int/value and FFh or (p4/value and FFFFFF00h)]
					2 [int/value and FFFFh or (p4/value and FFFF0000h)]
					4 [int/value]
				]
			]
			TYPE_FLOAT [
				f: as red-float! value
				either unit = 6 [
					pf: as pointer! [float!] p
					pf/value: f/value
				][
					pf32: as pointer! [float32!] p
					pf32/value: as float32! f/value
				]
			]
			default [
				fire [TO_ERROR(script invalid-type) datatype/push TYPE_OF(value)]
			]
		]
	]

	append-values: func [
		vec	[red-vector!]
		blk [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head blk
		tail:  block/rs-tail blk

		while [value < tail][
			rs-append vec value
			value: value + 1
		]
	]

	serialize: func [
		vec		[red-vector!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		mold?	[logic!]
		return: [integer!]
		/local
			s		[series!]
			p		[byte-ptr!]
			end		[byte-ptr!]
			unit	[integer!]
			pf		[pointer! [float!]]
			pf32	[pointer! [float32!]]
			formed	[c-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "vector/serialize"]]

		s: GET_BUFFER(vec)
		unit: GET_UNIT(s)
		p: (as byte-ptr! s/offset) + (vec/head << (unit >> 1))
		end: as byte-ptr! s/tail
		if unit = 6 [unit: 8]

		while [p < end][
			if all [OPTION?(arg) part <= 0][return part]

			either vec/type = TYPE_CHAR [
				part: either mold? [
					string/concatenate-literal buffer {#"}
					string/append-escaped-char
							buffer
							get-value-int as int-ptr! p unit
							string/ESC_CHAR
							all?
					string/append-char GET_BUFFER(buffer) as-integer #"^""
					part - 4
				][
					string/append-escaped-char
							buffer
							get-value-int as int-ptr! p unit
							string/ESC_CHAR
							all?
					part - 1
				]
			][
				either vec/type = TYPE_FLOAT [
					formed: either unit = 8 [
						pf: as pointer! [float!] p
						float/form-float pf/value float/FORM_FLOAT_64
					][
						pf32: as pointer! [float32!] p
						float/form-float as-float pf32/value float/FORM_FLOAT_32
					]
				][
					formed: integer/form-signed get-value-int as int-ptr! p unit
				]
				string/concatenate-literal buffer formed
				part: part - system/words/length? formed	;@@ optimize by removing length?
			]
			if p + unit < end [
				string/append-char GET_BUFFER(buffer) as-integer space
				part: part - 1
			]
			p: p + unit
		]
		part
	]

	do-math-scalar: func [
		op		[math-op!]
		left	[red-vector!]
		right	[red-value!]
		return: [red-value!]
		/local
			type	[integer!]
			s		[series!]
			unit	[integer!]
			len		[integer!]
			v1		[integer!]
			v2		[integer!]
			i		[integer!]
			p		[byte-ptr!]
			p4		[int-ptr!]
			f1		[float!]
			f2		[float!]
			pf		[pointer! [float!]]
			pf32	[pointer! [float32!]]
			int		[red-integer!]
			fl		[red-float!]
	][
		type: TYPE_OF(right)
		if all [
			type <> TYPE_INTEGER
			type <> TYPE_FLOAT
		][
			fire [TO_ERROR(script invalid-type) datatype/push type]
		]

		s: GET_BUFFER(left)
		unit: GET_UNIT(s)
		len: rs-length? left
		p: (as byte-ptr! s/offset) + (left/head << (unit >> 1))
		i: 0
		either left/type = TYPE_FLOAT [
			either type = TYPE_FLOAT [
				fl: as red-float! right
				f2: fl/value
			][
				int: as red-integer! right
				f2: integer/to-float int/value
			]
			if unit = 6 [unit: 8]
			while [i < len][
				f1: get-value-float p unit
				f1: switch op [
					OP_ADD [f1 + f2]
					OP_SUB [f1 - f2]
					OP_MUL [f1 * f2]
					OP_REM [f1 % f2]
					OP_DIV [
						either 0.0 = f2 [
							fire [TO_ERROR(math zero-divide)]
							0.0								;-- pass the compiler's type-checking
						][
							f1 / f2
						]
					]
					default [
						fire [TO_ERROR(script invalid-type) datatype/push left/type]
						0.0
					]
				]
				either unit = 8 [
					pf: as pointer! [float!] p
					pf/value: f1
				][
					pf32: as pointer! [float32!] p
					pf32/value: as float32! f1
				]
				i:  i  + 1
				p:  p  + unit
			]
		][
			either type = TYPE_INTEGER [
				int: as red-integer! right
				v2: int/value
			][
				fl: as red-float! right
				f1: fl/value
				v2: float/to-integer either f1 < 0.0 [f1 + 0.4999999999999999][f1 - 0.4999999999999999]
			]
			while [i < len][
				v1: get-value-int as int-ptr! p unit
				v1: switch op [
					OP_ADD [v1 + v2]
					OP_SUB [v1 - v2]
					OP_MUL [v1 * v2]
					OP_REM [v1 % v2]
					OP_AND [v1 and v2]
					OP_OR  [v1 or v2]
					OP_XOR [v1 xor v2]
					OP_DIV [
						either zero? v2 [
							fire [TO_ERROR(math zero-divide)]
							0								;-- pass the compiler's type-checking
						][
							v1 / v2
						]
					]
				]
				switch unit [
					1 [p/value: as-byte v1]
					2 [p/1: as-byte v1 p/2: as-byte v1 >> 8]
					4 [p4: as int-ptr! p p4/value: v1]
				]
				i:  i  + 1
				p:  p  + unit
			]
		]
		as red-value! left
	]

	do-math: func [
		type		[math-op!]
		return:		[red-value!]
		/local
			left	[red-vector!]
			right	[red-vector!]
			s1		[series!]
			s2		[series!]
			unit	[integer!]
			unit1	[integer!]
			unit2	[integer!]
			len		[integer!]
			len1	[integer!]
			len2	[integer!]
			v1		[integer!]
			v2		[integer!]
			i		[integer!]
			node	[node!]
			buffer	[series!]
			p		[byte-ptr!]
			p1		[byte-ptr!]
			p2		[byte-ptr!]
			p4		[int-ptr!]
			f1		[float!]
			f2		[float!]
			pf		[pointer! [float!]]
			pf32	[pointer! [float32!]]
	][
		left: as red-vector! stack/arguments
		right: left + 1

		if TYPE_OF(right) <> TYPE_VECTOR [
			return do-math-scalar type left as red-value! right
		]

		if left/type <> right/type [fire [TO_ERROR(script not-same-type)]]

		s1: GET_BUFFER(left)
		s2: GET_BUFFER(right)
		unit1: GET_UNIT(s1)
		unit2: GET_UNIT(s2)
		len1: rs-length? left
		len2: rs-length? right

		p1: (as byte-ptr! s1/offset) + (left/head << (unit1 >> 1))
		p2: (as byte-ptr! s2/offset) + (right/head << (unit2 >> 1))
		either len1 > len2 [len: len1][
			len: len2
			len2: len1							;-- set len2 to minimum length
			p: p1 p1: p2 p2: p
			unit: unit1 unit1: unit2 unit2: unit
		]
		unit: either unit1 > unit2 [unit1][unit2]
		node: alloc-bytes len << (unit >> 1)
		buffer: as series! node/value
		buffer/flags: buffer/flags and flag-unit-mask or unit
		buffer/tail: as cell! (as byte-ptr! buffer/offset) + (len << (unit >> 1))

		i: 0
		p:  as byte-ptr! buffer/offset
		either left/type = TYPE_FLOAT [
			if unit  = 6 [unit:  8]
			if unit1 = 6 [unit1: 8]
			if unit2 = 6 [unit2: 8]
			while [i < len][
				f1: get-value-float p1 unit1
				if i < len2 [
					f2: get-value-float p2 unit2
					f1: switch type [
						OP_ADD [f1 + f2]
						OP_SUB [f1 - f2]
						OP_MUL [f1 * f2]
						OP_REM [f1 % f2]
						OP_DIV [
							either 0.0 = f2 [
								fire [TO_ERROR(math zero-divide)]
								0.0								;-- pass the compiler's type-checking
							][
								f1 / f2
							]
						]
						default [
							fire [TO_ERROR(script invalid-type) datatype/push left/type]
							0.0
						]
					]
					p2: p2 + unit2
				]
				either unit = 8 [
					pf: as pointer! [float!] p
					pf/value: f1
				][
					pf32: as pointer! [float32!] p
					pf32/value: as float32! f1
				]
				i:  i  + 1
				p:  p  + unit
				p1: p1 + unit1
			]
		][
			while [i < len][
				v1: get-value-int as int-ptr! p1 unit1
				if i < len2 [
					v2: get-value-int as int-ptr! p2 unit2
					v1: switch type [
						OP_ADD [v1 + v2]
						OP_SUB [v1 - v2]
						OP_MUL [v1 * v2]
						OP_REM [v1 % v2]
						OP_AND [v1 and v2]
						OP_OR  [v1 or v2]
						OP_XOR [v1 xor v2]
						OP_DIV [
							either zero? v2 [
								fire [TO_ERROR(math zero-divide)]
								0								;-- pass the compiler's type-checking
							][
								v1 / v2
							]
						]
					]
					p2: p2 + unit2
				]
				switch unit [
					1 [p/value: as-byte v1]
					2 [p/1: as-byte v1 p/2: as-byte v1 >> 8]
					4 [p4: as int-ptr! p p4/value: v1]
				]
				i:  i  + 1
				p:  p  + unit
				p1: p1 + unit1
			]
		]
		left/node: node
		left/head: 0
		as red-value! left
	]

	clone: func [
		vec		[red-vector!]							;-- clone the vector in-place
		return: [red-vector!]
		/local
			new    [node!]
			s	   [series!]
			target [series!]
			size   [integer!]
	][
		s: GET_BUFFER(vec)
		size: s/size									;-- @@ head position ignored
		new: alloc-bytes size

		unless zero? size [
			target: as series! new/value
			copy-memory
				as byte-ptr! target/offset
				as byte-ptr! s/offset
				size
			target/tail: as cell! ((as byte-ptr! target/offset) + size)
		]
		vec/node: new
		vec
	]

	push: func [
		vec [red-vector!]
	][
		#if debug? = yes [if verbose > 0 [print-line "vector/push"]]

		copy-cell as red-value! vec stack/push*
	]

	make-at: func [
		slot	[red-value!]
		size	[integer!]
		type	[integer!]
		unit	[integer!]
		return: [red-vector!]
		/local
			vec [red-vector!]
			s	[series!]
	][
		vec: as red-vector! slot
		vec/header: TYPE_VECTOR							;-- implicit reset of all header flags
		vec/head: 	0
		vec/node: 	alloc-bytes size * unit
		vec/type:	type

		s: GET_BUFFER(vec)
		if unit = 8 [unit: 6]
		s/flags: s/flags and flag-unit-mask or unit
		vec
	]

	;--- Actions ---

	make: func [
		proto	[red-value!]
		spec	[red-value!]
		return:	[red-vector!]
		/local
			s	  [series!]
			w	  [red-word!]
			vec	  [red-vector!]
			int	  [red-integer!]
			value [red-value!]
			sym   [integer!]
			size  [integer!]
			blk-sz [integer!]
			unit  [integer!]
			type  [integer!]
			fill? [logic!]
			end   [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "vector/make"]]

		fill?: yes
		size: 0
		unit: 0
		type: TYPE_OF(spec)

		switch type [
			TYPE_INTEGER [
				int: as red-integer! spec
				size: int/value
			]
			TYPE_BLOCK [
				size:  block/rs-length? as red-block! spec
				either zero? size [
					type: TYPE_INTEGER
				][
					value: block/rs-head as red-block! spec
					type:  TYPE_OF(value)
					if type = TYPE_WORD [
						if size < 2 [
							fire [TO_ERROR(script bad-make-arg) proto spec]
						]

						;-- data type
						w: as red-word! value
						sym: symbol/resolve w/symbol
						type: case [
							sym = words/integer!	[TYPE_INTEGER]
							sym = words/char!		[TYPE_CHAR]
							sym = words/float!		[TYPE_FLOAT]
							true					[
								fire [TO_ERROR(script bad-make-arg) proto spec]
								0
							]
						]

						;-- bit size
						block/rs-next as red-block! spec
						value: block/rs-head as red-block! spec
						int: as red-integer! value
						unit: int/value >> 3
						unless any [unit = 4 unit = 2 unit = 1 unit = 8][
							fire [TO_ERROR(script bad-make-arg) proto spec]
						]

						;-- size or block values
						block/rs-next as red-block! spec
						value: block/rs-head as red-block! spec
						either TYPE_OF(value) = TYPE_INTEGER [
							int: as red-integer! value
							size: int/value
							either block/rs-next as red-block! spec [
								spec: value
							][
								spec: block/rs-head as red-block! spec
							]
						][
							either TYPE_OF(value) = TYPE_BLOCK [
								spec: value
								size: block/rs-length? as red-block! spec
							][
								fire [TO_ERROR(script invalid-spec-field) spec]
							]
						]
					]
					if zero? unit [
						unit:  switch type [
							TYPE_CHAR
							TYPE_INTEGER [size? integer!]
							TYPE_FLOAT	 [size? float!]
							default [
								fire [TO_ERROR(script invalid-type) datatype/push type]
								0
							]
						]
					]
				]
			]
			default [--NOT_IMPLEMENTED--]
		]

		if TYPE_OF(spec) = TYPE_BLOCK [
			blk-sz: block/rs-length? as red-block! spec
			if blk-sz >= size [size: blk-sz fill?: no]
		]
		if size <= 0 [fill?: no size: 1]
		if zero? unit [unit: 4]
		vec: make-at stack/push* size type unit

		if TYPE_OF(spec) = TYPE_BLOCK [
			append-values vec as red-block! spec
		]
		if fill? [
			s: GET_BUFFER(vec)
			end: (as byte-ptr! s/offset) + (size * unit)
			fill as byte-ptr! s/tail end null
			s/tail: as cell! end
		]
		vec
	]

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

		serialize vec buffer no no no arg part no
	]

	mold: func [
		vec		[red-vector!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent	[integer!]
		return:	[integer!]
		/local
			formed [c-string!]
			s	   [series!]
			unit   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "vector/mold"]]

		string/concatenate-literal buffer "make vector! ["
		part: part - 14

		s: GET_BUFFER(vec)
		unit: GET_UNIT(s)
		if unit = 6 [unit: 8]

		either any [
			all [unit = 4 any [vec/type = TYPE_CHAR vec/type = TYPE_INTEGER]]
			all [unit = 8 vec/type = TYPE_FLOAT]
		][
			part: serialize vec buffer only? all? flat? arg part yes
			string/append-char GET_BUFFER(buffer) as-integer #"]"
			part - 1
		][
			string/concatenate-literal buffer switch vec/type [
				TYPE_CHAR		[part: part - 5 "char!"]
				TYPE_INTEGER	[part: part - 8 "integer!"]
				TYPE_FLOAT		[part: part - 6 "float!"]
			]
			string/append-char GET_BUFFER(buffer) as-integer space

			formed: integer/form-signed unit << 3
			string/concatenate-literal buffer formed
			string/append-char GET_BUFFER(buffer) as-integer space
			part: part - system/words/length? formed

			string/append-char GET_BUFFER(buffer) as-integer #"["
			part: part - 4									;-- 3 spaces + "["

			part: serialize vec buffer only? all? flat? arg part yes

			string/concatenate-literal buffer "]]"
			part - 2
		]
	]

	compare: func [
		vec1	[red-vector!]
		vec2	[red-vector!]
		op		[integer!]
		return:	[integer!]
		/local
			s1		[series!]
			s2		[series!]
			unit	[integer!]
			unit1	[integer!]
			unit2	[integer!]
			type	[integer!]
			len1	[integer!]
			len2	[integer!]
			v1		[integer!]
			v2		[integer!]
			end 	[byte-ptr!]
			p1		[byte-ptr!]
			p2		[byte-ptr!]
			f1		[float!]
			f2		[float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "vector/compare"]]

		if TYPE_OF(vec2) <> TYPE_VECTOR [RETURN_COMPARE_OTHER]
		if vec1/type <> vec2/type [fire [TO_ERROR(script not-same-type)]]

		s1: GET_BUFFER(vec1)
		s2: GET_BUFFER(vec2)
		unit1: GET_UNIT(s1)
		unit2: GET_UNIT(s2)
		len1: rs-length? vec1
		len2: rs-length? vec2

		end: as byte-ptr! s2/tail

		either len1 <> len2 [							;-- shortcut exit for different sizes
			if any [
				op = COMP_EQUAL op = COMP_STRICT_EQUAL op = COMP_NOT_EQUAL
			][return 1]

			if len2 > len1 [
				end: end - (len2 - len1 << (unit2 >> 1))
			]
		][
			if zero? len1 [return 0]					;-- shortcut exit for empty vector!
		]

		type: vec1/type
		p1: (as byte-ptr! s1/offset) + (vec1/head << (unit1 >> 1))
		p2: (as byte-ptr! s2/offset) + (vec2/head << (unit2 >> 1))

		switch type [
			TYPE_CHAR
			TYPE_INTEGER [
				until [
					v1: get-value-int as int-ptr! p1 unit1
					v2: get-value-int as int-ptr! p2 unit2
					p1: p1 + unit1
					p2: p2 + unit2
					any [
						v1 <> v2
						p2 >= end
					]
				]
				if v1 = v2 [v1: len1 v2: len2]
				SIGN_COMPARE_RESULT(v1 v2)
			]
			TYPE_FLOAT [
				if unit1 = 6 [unit1: 8]
				if unit2 = 6 [unit2: 8]
				until [
					f1: get-value-float p1 unit1
					f2: get-value-float p2 unit2
					p1: p1 + unit1
					p2: p2 + unit2
					any [
						v1 <> v2
						p2 >= end
					]
				]
				either f1 = f2 [
					SIGN_COMPARE_RESULT(len1 len2)
				][
					SIGN_COMPARE_RESULT(f1 f2)
				]
			]
		]
	]

	;--- Modifying actions ---

	insert: func [
		vec		 [red-vector!]
		value	 [red-value!]
		part-arg [red-value!]
		only?	 [logic!]
		dup-arg	 [red-value!]
		append?	 [logic!]
		return:	 [red-value!]
		/local
			src		  [red-block!]
			cell	  [red-value!]
			limit	  [red-value!]
			int		  [red-integer!]
			char	  [red-char!]
			sp		  [red-vector!]
			s		  [series!]
			s2		  [series!]
			dup-n	  [integer!]
			cnt		  [integer!]
			part	  [integer!]
			len		  [integer!]
			added	  [integer!]
			vec-type  [integer!]
			tail?	  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "vector/insert"]]

		dup-n: 1
		cnt:   1
		part: -1
		vec-type: vec/type

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				int/value
			][
				sp: as red-vector! part-arg
				unless all [
					TYPE_OF(sp) = TYPE_VECTOR
					sp/node = vec/node
				][
					fire [TO_ERROR(script invalid-part) part-arg]
				]
				sp/head + 1								;-- /head is 0-based
			]
		]
		if OPTION?(dup-arg) [
			int: as red-integer! dup-arg
			cnt: int/value
			if negative? cnt [return as red-value! vec]
			dup-n: cnt
		]

		s: GET_BUFFER(vec)
		tail?: any [
			(as-integer s/tail - s/offset) >> (GET_UNIT(s) >> 1) = vec/head
			append?
		]

		while [not zero? cnt][							;-- /dup support
			either TYPE_OF(value) = TYPE_BLOCK [		;@@ replace it with: typeset/any-block?
				src: as red-block! value
				s2: GET_BUFFER(src)
				cell:  s2/offset + src/head
				limit: cell + block/rs-length? src
			][
				cell:  value
				limit: value + 1
			]
			added: 0

			while [all [cell < limit added <> part]][	;-- multiple values case
				if TYPE_OF(cell) <> vec-type [
					fire [TO_ERROR(script invalid-type) datatype/push TYPE_OF(cell)]
				]
				either tail? [
					rs-append vec cell
				][
					rs-insert vec vec/head + added cell
				]
				added: added + 1
				cell: cell + 1
			]
			cnt: cnt - 1
		]
		unless append? [
			added: added * dup-n
			vec/head: vec/head + added
			s: GET_BUFFER(vec)
			assert (as byte-ptr! s/offset) + (vec/head << (GET_UNIT(s) >> 1)) <= as byte-ptr! s/tail
		]
		as red-value! vec
	]

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

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

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

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

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

	and~: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "vector/and~"]]
		do-math OP_AND
	]

	or~: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "vector/or~"]]
		do-math OP_OR
	]

	xor~: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "vector/xor~"]]
		do-math OP_XOR
	]

	init: does [
		datatype/register [
			TYPE_VECTOR
			TYPE_STRING
			"vector!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			INHERIT_ACTION	;eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			null			;absolute
			:add
			:divide
			:multiply
			null			;negate
			null			;power
			:remainder
			null			;round
			:subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			:and~
			null			;complement
			:or~
			:xor~
			;-- Series actions --
			null			;append
			INHERIT_ACTION	;at
			INHERIT_ACTION	;back
			null			;change
			INHERIT_ACTION	;clear
			INHERIT_ACTION	;copy
			INHERIT_ACTION	;find
			INHERIT_ACTION	;head
			INHERIT_ACTION	;head?
			INHERIT_ACTION	;index?
			:insert
			INHERIT_ACTION	;length?
			INHERIT_ACTION	;next
			INHERIT_ACTION	;pick
			INHERIT_ACTION	;poke
			INHERIT_ACTION	;remove
			INHERIT_ACTION	;reverse
			INHERIT_ACTION	;select
			INHERIT_ACTION	;sort
			INHERIT_ACTION	;skip
			null			;swap
			INHERIT_ACTION	;tail
			INHERIT_ACTION	;tail?
			INHERIT_ACTION	;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:   "Vector! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %vector.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
]

vector: context [
	verbose: 0

	rs-length?: func [
		vec 	[red-vector!]
		return: [integer!]
	][
		string/get-length as red-string! vec no
	]

	rs-skip: func [
		vec 	[red-vector!]
		len		[integer!]
		return: [logic!]
	][
		string/rs-skip as red-string! vec len
	]

	rs-next: func [
		vec 	[red-vector!]
		return: [logic!]
		/local
			s [series!]
	][
		rs-skip vec 1
	]

	rs-head: func [
		vec	    [red-vector!]
		return: [byte-ptr!]
		/local
			s [series!]
	][
		s: GET_BUFFER(vec)
		(as byte-ptr! s/offset) + (vec/head << (GET_UNIT(s) >> 1))
	]

	rs-tail: func [
		vec	    [red-vector!]
		return: [byte-ptr!]
		/local
			s [series!]
	][
		s: GET_BUFFER(vec)
		as byte-ptr! s/tail
	]

	rs-tail?: func [
		vec	    [red-vector!]
		return: [logic!]
		/local
			s [series!]
	][
		s: GET_BUFFER(vec)
		(as byte-ptr! s/offset) + (vec/head << (GET_UNIT(s) >> 1)) >= as byte-ptr! s/tail
	]

	rs-clear: func [
		vec [red-vector!]
		/local
			s [series!]
	][
		s: GET_BUFFER(vec)
		s/tail: as cell! (as byte-ptr! s/offset) + (vec/head << (GET_UNIT(s) >> 1))
	]

	rs-append-int: func [
		vec		[red-vector!]
		n		[integer!]
		/local
			s	 [series!]
			p	 [byte-ptr!]
			p4	 [int-ptr!]
	][
		s: GET_BUFFER(vec)
		p: alloc-tail-unit s 4
		p4: as int-ptr! p
		p4/value: n
	]

	rs-append: func [
		vec		[red-vector!]
		value	[red-value!]
		return: [red-value!]
		/local
			s	 [series!]
			p	 [byte-ptr!]
			unit [integer!]
	][
		if vec/type <> TYPE_OF(value) [
			fire [TO_ERROR(script invalid-arg) value]
		]

		assert TYPE_OF(value) = vec/type
		s: GET_BUFFER(vec)
		unit: GET_UNIT(s)
		p: alloc-tail-unit s either unit = 6 [8][unit]
		set-value p value unit
		value
	]

	rs-insert: func [
		vec		[red-vector!]
		offset	[integer!]								;-- offset from head in elements
		value	[red-value!]
		return: [series!]
		/local
			s	  [series!]
			p	  [byte-ptr!]
			unit  [integer!]
			unit2 [integer!]
	][
		if vec/type <> TYPE_OF(value) [
			fire [TO_ERROR(script invalid-arg) value]
		]

		s: GET_BUFFER(vec)
		unit: GET_UNIT(s)
		unit2: either unit = 6 [8][unit]

		if ((as byte-ptr! s/tail) + unit2) > ((as byte-ptr! s + 1) + s/size) [
			s: expand-series s 0
		]
		p: (as byte-ptr! s/offset) + (offset << (unit >> 1))

		move-memory										;-- make space
			p + unit2
			p
			as-integer (as byte-ptr! s/tail) - p

		s/tail: as cell! (as byte-ptr! s/tail) + unit2

		set-value p value unit
		s
	]

	get-value-int: func [
		p		[int-ptr!]
		unit	[integer!]
		return: [integer!]
	][
		switch unit [
			1 [p/value and FFh]
			2 [p/value and FFFFh]
			4 [p/value]
		]
	]

	get-value-float: func [
		p		[byte-ptr!]
		unit	[integer!]
		return: [float!]
		/local
			pf	 [pointer! [float!]]
			pf32 [pointer! [float32!]]
	][
		either unit = 4 [
			pf32: as pointer! [float32!] p
			as-float pf32/value
		][
			pf: as pointer! [float!] p
			pf/value
		]
	]

	get-value: func [
		p		[byte-ptr!]
		unit	[integer!]
		type	[integer!]
		return: [red-value!]
		/local
			int    [red-integer!]
			float  [red-float!]
	][
		switch type [
			TYPE_CHAR
			TYPE_INTEGER [
				int: as red-integer! stack/push*
				int/header: type
				int/value: get-value-int as int-ptr! p unit
				as red-value! int
			]
			TYPE_FLOAT [
				float: as red-float! stack/push*
				float/header: TYPE_FLOAT
				float/value: get-value-float p unit
				as red-value! float
			]
		]
	]

	set-value: func [
		p		[byte-ptr!]
		value	[red-value!]
		unit	[integer!]
		/local
			int  [red-integer!]
			f	 [red-float!]
			p4	 [int-ptr!]
			pf	 [pointer! [float!]]
			pf32 [pointer! [float32!]]
	][
		switch TYPE_OF(value) [
			TYPE_CHAR
			TYPE_INTEGER [ 			;-- char! and integer! structs are overlapping
				int: as red-integer! value
				p4: as int-ptr! p
				p4/value: switch unit [
					1 [int/value and FFh or (p4/value and FFFFFF00h)]
					2 [int/value and FFFFh or (p4/value and FFFF0000h)]
					4 [int/value]
				]
			]
			TYPE_FLOAT [
				f: as red-float! value
				either unit = 6 [
					pf: as pointer! [float!] p
					pf/value: f/value
				][
					pf32: as pointer! [float32!] p
					pf32/value: as float32! f/value
				]
			]
			default [
				fire [TO_ERROR(script invalid-type) datatype/push TYPE_OF(value)]
			]
		]
	]

	append-values: func [
		vec	[red-vector!]
		blk [red-block!]
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head blk
		tail:  block/rs-tail blk

		while [value < tail][
			rs-append vec value
			value: value + 1
		]
	]

	serialize: func [
		vec		[red-vector!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		mold?	[logic!]
		return: [integer!]
		/local
			s		[series!]
			p		[byte-ptr!]
			end		[byte-ptr!]
			unit	[integer!]
			pf		[pointer! [float!]]
			pf32	[pointer! [float32!]]
			formed	[c-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "vector/serialize"]]

		s: GET_BUFFER(vec)
		unit: GET_UNIT(s)
		p: (as byte-ptr! s/offset) + (vec/head << (unit >> 1))
		end: as byte-ptr! s/tail
		if unit = 6 [unit: 8]

		while [p < end][
			if all [OPTION?(arg) part <= 0][return part]

			either vec/type = TYPE_CHAR [
				part: either mold? [
					string/concatenate-literal buffer {#"}
					string/append-escaped-char
							buffer
							get-value-int as int-ptr! p unit
							string/ESC_CHAR
							all?
					string/append-char GET_BUFFER(buffer) as-integer #"^""
					part - 4
				][
					string/append-escaped-char
							buffer
							get-value-int as int-ptr! p unit
							string/ESC_CHAR
							all?
					part - 1
				]
			][
				either vec/type = TYPE_FLOAT [
					formed: either unit = 8 [
						pf: as pointer! [float!] p
						float/form-float pf/value float/FORM_FLOAT_64
					][
						pf32: as pointer! [float32!] p
						float/form-float as-float pf32/value float/FORM_FLOAT_32
					]
				][
					formed: integer/form-signed get-value-int as int-ptr! p unit
				]
				string/concatenate-literal buffer formed
				part: part - system/words/length? formed	;@@ optimize by removing length?
			]
			if p + unit < end [
				string/append-char GET_BUFFER(buffer) as-integer space
				part: part - 1
			]
			p: p + unit
		]
		part
	]

	do-math-scalar: func [
		op		[math-op!]
		left	[red-vector!]
		right	[red-value!]
		return: [red-value!]
		/local
			type	[integer!]
			s		[series!]
			unit	[integer!]
			len		[integer!]
			v1		[integer!]
			v2		[integer!]
			i		[integer!]
			p		[byte-ptr!]
			p4		[int-ptr!]
			f1		[float!]
			f2		[float!]
			pf		[pointer! [float!]]
			pf32	[pointer! [float32!]]
			int		[red-integer!]
			fl		[red-float!]
	][
		type: TYPE_OF(right)
		if all [
			type <> TYPE_INTEGER
			type <> TYPE_FLOAT
		][
			fire [TO_ERROR(script invalid-type) datatype/push type]
		]

		s: GET_BUFFER(left)
		unit: GET_UNIT(s)
		len: rs-length? left
		p: (as byte-ptr! s/offset) + (left/head << (unit >> 1))
		i: 0
		either left/type = TYPE_FLOAT [
			either type = TYPE_FLOAT [
				fl: as red-float! right
				f2: fl/value
			][
				int: as red-integer! right
				f2: integer/to-float int/value
			]
			if unit = 6 [unit: 8]
			while [i < len][
				f1: get-value-float p unit
				f1: switch op [
					OP_ADD [f1 + f2]
					OP_SUB [f1 - f2]
					OP_MUL [f1 * f2]
					OP_REM [f1 % f2]
					OP_DIV [
						either 0.0 = f2 [
							fire [TO_ERROR(math zero-divide)]
							0.0								;-- pass the compiler's type-checking
						][
							f1 / f2
						]
					]
					default [
						fire [TO_ERROR(script invalid-type) datatype/push left/type]
						0.0
					]
				]
				either unit = 8 [
					pf: as pointer! [float!] p
					pf/value: f1
				][
					pf32: as pointer! [float32!] p
					pf32/value: as float32! f1
				]
				i:  i  + 1
				p:  p  + unit
			]
		][
			either type = TYPE_INTEGER [
				int: as red-integer! right
				v2: int/value
			][
				fl: as red-float! right
				v2: float/to-integer fl/value
			]
			while [i < len][
				v1: get-value-int as int-ptr! p unit
				v1: switch op [
					OP_ADD [v1 + v2]
					OP_SUB [v1 - v2]
					OP_MUL [v1 * v2]
					OP_REM [v1 % v2]
					OP_AND [v1 and v2]
					OP_OR  [v1 or v2]
					OP_XOR [v1 xor v2]
					OP_DIV [
						either zero? v2 [
							fire [TO_ERROR(math zero-divide)]
							0								;-- pass the compiler's type-checking
						][
							v1 / v2
						]
					]
				]
				switch unit [
					1 [p/value: as-byte v1]
					2 [p/1: as-byte v1 p/2: as-byte v1 >> 8]
					4 [p4: as int-ptr! p p4/value: v1]
				]
				i:  i  + 1
				p:  p  + unit
			]
		]
		as red-value! left
	]

	do-math: func [
		type		[math-op!]
		return:		[red-value!]
		/local
			left	[red-vector!]
			right	[red-vector!]
			s1		[series!]
			s2		[series!]
			unit	[integer!]
			unit1	[integer!]
			unit2	[integer!]
			len		[integer!]
			len1	[integer!]
			len2	[integer!]
			v1		[integer!]
			v2		[integer!]
			i		[integer!]
			node	[node!]
			buffer	[series!]
			p		[byte-ptr!]
			p1		[byte-ptr!]
			p2		[byte-ptr!]
			p4		[int-ptr!]
			f1		[float!]
			f2		[float!]
			pf		[pointer! [float!]]
			pf32	[pointer! [float32!]]
	][
		left: as red-vector! stack/arguments
		right: left + 1

		if TYPE_OF(right) <> TYPE_VECTOR [
			return do-math-scalar type left as red-value! right
		]

		if left/type <> right/type [fire [TO_ERROR(script not-same-type)]]

		s1: GET_BUFFER(left)
		s2: GET_BUFFER(right)
		unit1: GET_UNIT(s1)
		unit2: GET_UNIT(s2)
		len1: rs-length? left
		len2: rs-length? right

		p1: (as byte-ptr! s1/offset) + (left/head << (unit1 >> 1))
		p2: (as byte-ptr! s2/offset) + (right/head << (unit2 >> 1))
		either len1 > len2 [len: len1][
			len: len2
			len2: len1							;-- set len2 to minimum length
			p: p1 p1: p2 p2: p
			unit: unit1 unit1: unit2 unit2: unit
		]
		unit: either unit1 > unit2 [unit1][unit2]
		node: alloc-bytes len << (unit >> 1)
		buffer: as series! node/value
		buffer/flags: buffer/flags and flag-unit-mask or unit
		buffer/tail: as cell! (as byte-ptr! buffer/offset) + (len << (unit >> 1))

		i: 0
		p:  as byte-ptr! buffer/offset
		either left/type = TYPE_FLOAT [
			if unit  = 6 [unit:  8]
			if unit1 = 6 [unit1: 8]
			if unit2 = 6 [unit2: 8]
			while [i < len][
				f1: get-value-float p1 unit1
				if i < len2 [
					f2: get-value-float p2 unit2
					f1: switch type [
						OP_ADD [f1 + f2]
						OP_SUB [f1 - f2]
						OP_MUL [f1 * f2]
						OP_REM [f1 % f2]
						OP_DIV [
							either 0.0 = f2 [
								fire [TO_ERROR(math zero-divide)]
								0.0								;-- pass the compiler's type-checking
							][
								f1 / f2
							]
						]
						default [
							fire [TO_ERROR(script invalid-type) datatype/push left/type]
							0.0
						]
					]
					p2: p2 + unit2
				]
				either unit = 8 [
					pf: as pointer! [float!] p
					pf/value: f1
				][
					pf32: as pointer! [float32!] p
					pf32/value: as float32! f1
				]
				i:  i  + 1
				p:  p  + unit
				p1: p1 + unit1
			]
		][
			while [i < len][
				v1: get-value-int as int-ptr! p1 unit1
				if i < len2 [
					v2: get-value-int as int-ptr! p2 unit2
					v1: switch type [
						OP_ADD [v1 + v2]
						OP_SUB [v1 - v2]
						OP_MUL [v1 * v2]
						OP_REM [v1 % v2]
						OP_AND [v1 and v2]
						OP_OR  [v1 or v2]
						OP_XOR [v1 xor v2]
						OP_DIV [
							either zero? v2 [
								fire [TO_ERROR(math zero-divide)]
								0								;-- pass the compiler's type-checking
							][
								v1 / v2
							]
						]
					]
					p2: p2 + unit2
				]
				switch unit [
					1 [p/value: as-byte v1]
					2 [p/1: as-byte v1 p/2: as-byte v1 >> 8]
					4 [p4: as int-ptr! p p4/value: v1]
				]
				i:  i  + 1
				p:  p  + unit
				p1: p1 + unit1
			]
		]
		left/node: node
		left/head: 0
		as red-value! left
	]

	clone: func [
		vec		[red-vector!]							;-- clone the vector in-place
		return: [red-vector!]
		/local
			new    [node!]
			s	   [series!]
			target [series!]
			size   [integer!]
	][
		s: GET_BUFFER(vec)
		size: s/size									;-- @@ head position ignored
		new: alloc-bytes size

		unless zero? size [
			target: as series! new/value
			copy-memory
				as byte-ptr! target/offset
				as byte-ptr! s/offset
				size
			target/tail: as cell! ((as byte-ptr! target/offset) + size)
		]
		vec/node: new
		vec
	]

	push: func [
		vec [red-vector!]
	][
		#if debug? = yes [if verbose > 0 [print-line "vector/push"]]

		copy-cell as red-value! vec stack/push*
	]

	make-at: func [
		slot	[red-value!]
		size	[integer!]
		type	[integer!]
		unit	[integer!]
		return: [red-vector!]
		/local
			vec [red-vector!]
			s	[series!]
	][
		vec: as red-vector! slot
		vec/header: TYPE_VECTOR							;-- implicit reset of all header flags
		vec/head: 	0
		vec/node: 	alloc-bytes size * unit
		vec/type:	type

		s: GET_BUFFER(vec)
		if unit = 8 [unit: 6]
		s/flags: s/flags and flag-unit-mask or unit
		vec
	]

	;--- Actions ---

	make: func [
		proto	[red-value!]
		spec	[red-value!]
		return:	[red-vector!]
		/local
			s	  [series!]
			w	  [red-word!]
			vec	  [red-vector!]
			int	  [red-integer!]
			value [red-value!]
			sym   [integer!]
			size  [integer!]
			blk-sz [integer!]
			unit  [integer!]
			type  [integer!]
			fill? [logic!]
			end   [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "vector/make"]]

		fill?: yes
		size: 0
		unit: 0
		type: TYPE_OF(spec)

		switch type [
			TYPE_INTEGER [
				int: as red-integer! spec
				size: int/value
			]
			TYPE_BLOCK [
				size:  block/rs-length? as red-block! spec
				either zero? size [
					type: TYPE_INTEGER
				][
					value: block/rs-head as red-block! spec
					type:  TYPE_OF(value)
					if type = TYPE_WORD [
						if size < 2 [
							fire [TO_ERROR(script bad-make-arg) proto spec]
						]

						;-- data type
						w: as red-word! value
						sym: symbol/resolve w/symbol
						type: case [
							sym = words/integer!	[TYPE_INTEGER]
							sym = words/char!		[TYPE_CHAR]
							sym = words/float!		[TYPE_FLOAT]
							true					[
								fire [TO_ERROR(script bad-make-arg) proto spec]
								0
							]
						]

						;-- bit size
						block/rs-next as red-block! spec
						value: block/rs-head as red-block! spec
						int: as red-integer! value
						unit: int/value >> 3
						unless any [unit = 4 unit = 2 unit = 1 unit = 8][
							fire [TO_ERROR(script bad-make-arg) proto spec]
						]

						;-- size or block values
						block/rs-next as red-block! spec
						value: block/rs-head as red-block! spec
						either TYPE_OF(value) = TYPE_INTEGER [
							int: as red-integer! value
							size: int/value
							either block/rs-next as red-block! spec [
								spec: value
							][
								spec: block/rs-head as red-block! spec
							]
						][
							either TYPE_OF(value) = TYPE_BLOCK [
								spec: value
								size: block/rs-length? as red-block! spec
							][
								fire [TO_ERROR(script invalid-spec-field) spec]
							]
						]
					]
					if zero? unit [
						unit:  switch type [
							TYPE_CHAR
							TYPE_INTEGER [size? integer!]
							TYPE_FLOAT	 [size? float!]
							default [
								fire [TO_ERROR(script invalid-type) datatype/push type]
								0
							]
						]
					]
				]
			]
			default [--NOT_IMPLEMENTED--]
		]

		if TYPE_OF(spec) = TYPE_BLOCK [
			blk-sz: block/rs-length? as red-block! spec
			if blk-sz >= size [size: blk-sz fill?: no]
		]
		if size <= 0 [fill?: no size: 1]
		if zero? unit [unit: 4]
		vec: make-at stack/push* size type unit

		if TYPE_OF(spec) = TYPE_BLOCK [
			append-values vec as red-block! spec
		]
		if fill? [
			s: GET_BUFFER(vec)
			end: (as byte-ptr! s/offset) + (size * unit)
			fill as byte-ptr! s/tail end null
			s/tail: as cell! end
		]
		vec
	]

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

		serialize vec buffer no no no arg part no
	]

	mold: func [
		vec		[red-vector!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent	[integer!]
		return:	[integer!]
		/local
			formed [c-string!]
			s	   [series!]
			unit   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "vector/mold"]]

		string/concatenate-literal buffer "make vector! ["
		part: part - 14

		s: GET_BUFFER(vec)
		unit: GET_UNIT(s)
		if unit = 6 [unit: 8]

		either any [
			all [unit = 4 any [vec/type = TYPE_CHAR vec/type = TYPE_INTEGER]]
			all [unit = 8 vec/type = TYPE_FLOAT]
		][
			part: serialize vec buffer only? all? flat? arg part yes
			string/append-char GET_BUFFER(buffer) as-integer #"]"
			part - 1
		][
			string/concatenate-literal buffer switch vec/type [
				TYPE_CHAR		[part: part - 5 "char!"]
				TYPE_INTEGER	[part: part - 8 "integer!"]
				TYPE_FLOAT		[part: part - 6 "float!"]
			]
			string/append-char GET_BUFFER(buffer) as-integer space

			formed: integer/form-signed unit << 3
			string/concatenate-literal buffer formed
			string/append-char GET_BUFFER(buffer) as-integer space
			part: part - system/words/length? formed

			string/append-char GET_BUFFER(buffer) as-integer #"["
			part: part - 4									;-- 3 spaces + "["

			part: serialize vec buffer only? all? flat? arg part yes

			string/concatenate-literal buffer "]]"
			part - 2
		]
	]

	compare: func [
		vec1	[red-vector!]
		vec2	[red-vector!]
		op		[integer!]
		return:	[integer!]
		/local
			s1		[series!]
			s2		[series!]
			unit	[integer!]
			unit1	[integer!]
			unit2	[integer!]
			type	[integer!]
			len1	[integer!]
			len2	[integer!]
			v1		[integer!]
			v2		[integer!]
			end 	[byte-ptr!]
			p1		[byte-ptr!]
			p2		[byte-ptr!]
			f1		[float!]
			f2		[float!]
	][
		#if debug? = yes [if verbose > 0 [print-line "vector/compare"]]

		if TYPE_OF(vec2) <> TYPE_VECTOR [RETURN_COMPARE_OTHER]
		if vec1/type <> vec2/type [fire [TO_ERROR(script not-same-type)]]

		s1: GET_BUFFER(vec1)
		s2: GET_BUFFER(vec2)
		unit1: GET_UNIT(s1)
		unit2: GET_UNIT(s2)
		len1: rs-length? vec1
		len2: rs-length? vec2

		end: as byte-ptr! s2/tail

		either len1 <> len2 [							;-- shortcut exit for different sizes
			if any [
				op = COMP_EQUAL op = COMP_STRICT_EQUAL op = COMP_NOT_EQUAL
			][return 1]

			if len2 > len1 [
				end: end - (len2 - len1 << (unit2 >> 1))
			]
		][
			if zero? len1 [return 0]					;-- shortcut exit for empty vector!
		]

		type: vec1/type
		p1: (as byte-ptr! s1/offset) + (vec1/head << (unit1 >> 1))
		p2: (as byte-ptr! s2/offset) + (vec2/head << (unit2 >> 1))

		switch type [
			TYPE_CHAR
			TYPE_INTEGER [
				until [
					v1: get-value-int as int-ptr! p1 unit1
					v2: get-value-int as int-ptr! p2 unit2
					p1: p1 + unit1
					p2: p2 + unit2
					any [
						v1 <> v2
						p2 >= end
					]
				]
				if v1 = v2 [v1: len1 v2: len2]
				SIGN_COMPARE_RESULT(v1 v2)
			]
			TYPE_FLOAT [
				if unit1 = 6 [unit1: 8]
				if unit2 = 6 [unit2: 8]
				until [
					f1: get-value-float p1 unit1
					f2: get-value-float p2 unit2
					p1: p1 + unit1
					p2: p2 + unit2
					any [
						v1 <> v2
						p2 >= end
					]
				]
				either f1 = f2 [
					SIGN_COMPARE_RESULT(len1 len2)
				][
					SIGN_COMPARE_RESULT(f1 f2)
				]
			]
		]
	]

	;--- Modifying actions ---

	insert: func [
		vec		 [red-vector!]
		value	 [red-value!]
		part-arg [red-value!]
		only?	 [logic!]
		dup-arg	 [red-value!]
		append?	 [logic!]
		return:	 [red-value!]
		/local
			src		  [red-block!]
			cell	  [red-value!]
			limit	  [red-value!]
			int		  [red-integer!]
			char	  [red-char!]
			sp		  [red-vector!]
			s		  [series!]
			s2		  [series!]
			dup-n	  [integer!]
			cnt		  [integer!]
			part	  [integer!]
			len		  [integer!]
			added	  [integer!]
			vec-type  [integer!]
			tail?	  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "vector/insert"]]

		dup-n: 1
		cnt:   1
		part: -1
		vec-type: vec/type

		if OPTION?(part-arg) [
			part: either TYPE_OF(part-arg) = TYPE_INTEGER [
				int: as red-integer! part-arg
				int/value
			][
				sp: as red-vector! part-arg
				unless all [
					TYPE_OF(sp) = TYPE_VECTOR
					sp/node = vec/node
				][
					fire [TO_ERROR(script invalid-part) part-arg]
				]
				sp/head + 1								;-- /head is 0-based
			]
		]
		if OPTION?(dup-arg) [
			int: as red-integer! dup-arg
			cnt: int/value
			if negative? cnt [return as red-value! vec]
			dup-n: cnt
		]

		s: GET_BUFFER(vec)
		tail?: any [
			(as-integer s/tail - s/offset) >> (GET_UNIT(s) >> 1) = vec/head
			append?
		]

		while [not zero? cnt][							;-- /dup support
			either TYPE_OF(value) = TYPE_BLOCK [		;@@ replace it with: typeset/any-block?
				src: as red-block! value
				s2: GET_BUFFER(src)
				cell:  s2/offset + src/head
				limit: cell + block/rs-length? src
			][
				cell:  value
				limit: value + 1
			]
			added: 0

			while [all [cell < limit added <> part]][	;-- multiple values case
				if TYPE_OF(cell) <> vec-type [
					fire [TO_ERROR(script invalid-type) datatype/push TYPE_OF(cell)]
				]
				either tail? [
					rs-append vec cell
				][
					rs-insert vec vec/head + added cell
				]
				added: added + 1
				cell: cell + 1
			]
			cnt: cnt - 1
		]
		unless append? [
			added: added * dup-n
			vec/head: vec/head + added
			s: GET_BUFFER(vec)
			assert (as byte-ptr! s/offset) + (vec/head << (GET_UNIT(s) >> 1)) <= as byte-ptr! s/tail
		]
		as red-value! vec
	]

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

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

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

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

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

	and~: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "vector/and~"]]
		do-math OP_AND
	]

	or~: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "vector/or~"]]
		do-math OP_OR
	]

	xor~: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "vector/xor~"]]
		do-math OP_XOR
	]

	init: does [
		datatype/register [
			TYPE_VECTOR
			TYPE_STRING
			"vector!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			INHERIT_ACTION	;eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			null			;absolute
			:add
			:divide
			:multiply
			null			;negate
			null			;power
			:remainder
			null			;round
			:subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			:and~
			null			;complement
			:or~
			:xor~
			;-- Series actions --
			null			;append
			INHERIT_ACTION	;at
			INHERIT_ACTION	;back
			null			;change
			INHERIT_ACTION	;clear
			INHERIT_ACTION	;copy
			INHERIT_ACTION	;find
			INHERIT_ACTION	;head
			INHERIT_ACTION	;head?
			INHERIT_ACTION	;index?
			:insert
			INHERIT_ACTION	;length?
			INHERIT_ACTION	;next
			INHERIT_ACTION	;pick
			INHERIT_ACTION	;poke
			INHERIT_ACTION	;remove
			INHERIT_ACTION	;reverse
			INHERIT_ACTION	;select
			INHERIT_ACTION	;sort
			INHERIT_ACTION	;skip
			null			;swap
			INHERIT_ACTION	;tail
			INHERIT_ACTION	;tail?
			INHERIT_ACTION	;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
		]
	]
]


FEAT: added definition for default! typeset.

Red [
	Title:   "Red base environment definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %boot.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 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
	}
]

Red: true												;-- ultimate Truth ;-) (pre-defines Red word)

yes: on: true
no: off: false

tab:		 #"^-"
cr: 		 #"^M"
newline: lf: #"^/"
escape:      #"^["
slash: 		 #"/"
sp: space: 	 #" "
null: 		 #"^@"
crlf:		 "^M^/"
dot:		 #"."
comma:		 #","

pi: 3.141592653589793

internal!:		make typeset! [unset!]
number!:		make typeset! [integer! float!]
scalar!:		union number! make typeset! [char!]
any-word!:		make typeset! [word! set-word! get-word! lit-word! refinement! issue!]
any-path!:		make typeset! [path! set-path! get-path! lit-path!]
any-block!:		union any-path! make typeset! [block! paren!]
any-function!:	make typeset! [native! action! op! function! routine!]
any-object!:	make typeset! [object! error!]
any-string!:	make typeset! [string! file! url!]
series!:		union make typeset! [vector!] union any-block! any-string!
immediate!:		union scalar! union any-word! make typeset! [none! logic! datatype! typeset!]
default!:		union series! union immediate! union any-object! union any-function! make typeset! [bitset!]
any-type!:		union default! internal!

Red [
	Title:   "Red base environment definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %boot.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 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
	}
]

Red: true												;-- ultimate Truth ;-) (pre-defines Red word)

yes: on: true
no: off: false

tab:		 #"^-"
cr: 		 #"^M"
newline: lf: #"^/"
escape:      #"^["
slash: 		 #"/"
sp: space: 	 #" "
null: 		 #"^@"
crlf:		 "^M^/"
dot:		 #"."
comma:		 #","

pi: 3.141592653589793

internal!:		make typeset! [unset!]
number!:		make typeset! [integer! float!]
scalar!:		union number! make typeset! [char!]
any-word!:		make typeset! [word! set-word! get-word! lit-word! refinement! issue!]
any-path!:		make typeset! [path! set-path! get-path! lit-path!]
any-block!:		union any-path! make typeset! [block! paren!]
any-function!:	make typeset! [native! action! op! function! routine!]
any-object!:	make typeset! [object! error!]
any-string!:	make typeset! [string! file! url!]
series!:        union make typeset! [vector!] union any-block! any-string!
immediate!:		union scalar! union any-word! make typeset! [none! logic! datatype! typeset!]
any-type!:		union series!
					union immediate!
						union internal!
							union any-object!
								union any-function! bitset!


FIX: (Windows) Allow Red/System programs to output ANSI text when binding to Red's runtime and not setting the Unicode? compiler option to TRUE.

Red/System [
	Title:   "Red runtime win32 API imported functions definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %win32.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt
	}
]

#define VA_COMMIT_RESERVE	3000h						;-- MEM_COMMIT | MEM_RESERVE
#define VA_PAGE_RW			04h							;-- PAGE_READWRITE
#define VA_PAGE_RWX			40h							;-- PAGE_EXECUTE_READWRITE

#define _O_TEXT        	 	4000h  						;-- file mode is text (translated)
#define _O_BINARY       	8000h  						;-- file mode is binary (untranslated)
#define _O_WTEXT        	00010000h 					;-- file mode is UTF16 (translated)
#define _O_U16TEXT      	00020000h 					;-- file mode is UTF16 no BOM (translated)
#define _O_U8TEXT       	00040000h 					;-- file mode is UTF8  no BOM (translated)

platform: context [

	#enum file-descriptors! [
		fd-stdout: 1									;@@ hardcoded, safe?
		fd-stderr: 2									;@@ hardcoded, safe?
	]

	page-size: 4096

	#import [
		LIBC-file cdecl [
			putwchar: "putwchar" [
				wchar		[integer!]					;-- wchar is 16-bit on Windows
			]
			wprintf: "wprintf_s" [
				[variadic]
				return: 	[integer!]
			]
			_setmode: "_setmode" [
				handle		[integer!]
				mode		[integer!]
				return:		[integer!]
			]
			;_open_osfhandle: "_open_osfhandle" [
			;	handle		[integer!]
			;	flags		[integer!]
			;	return:		[integer!]
			;]
		]
		"kernel32.dll" stdcall [
			VirtualAlloc: "VirtualAlloc" [
				address		[byte-ptr!]
				size		[integer!]
				type		[integer!]
				protection	[integer!]
				return:		[int-ptr!]
			]
			VirtualFree: "VirtualFree" [
				address 	[int-ptr!]
				size		[integer!]
				return:		[integer!]
			]
		]
	]

	;-------------------------------------------
	;-- Allocate paged virtual memory region from OS
	;-------------------------------------------
	allocate-virtual: func [
		size 	[integer!]								;-- allocated size in bytes (page size multiple)
		exec? 	[logic!]								;-- TRUE => executable region
		return: [int-ptr!]								;-- allocated memory region pointer
		/local ptr prot
	][
		prot: either exec? [VA_PAGE_RWX][VA_PAGE_RW]

		ptr: VirtualAlloc
			null
			size
			VA_COMMIT_RESERVE
			prot

		if ptr = null [
			raise-error RED_ERR_VMEM_OUT_OF_MEMORY 0
		]
		ptr
	]

	;-------------------------------------------
	;-- Free paged virtual memory region from OS
	;-------------------------------------------
	free-virtual: func [
		ptr [int-ptr!]									;-- address of memory region to release
	][
		if negative? VirtualFree ptr ptr/value [
			raise-error RED_ERR_VMEM_RELEASE_FAILED as-integer ptr
		]
	]

	;-------------------------------------------
	;-- Print a UCS-4 string to console
	;-------------------------------------------
	print-UCS4: func [
		str    [int-ptr!]								;-- zero-terminated UCS-4 string
		/local
			cp [integer!]								;-- codepoint
	][
		assert str <> null

		while [cp: str/value not zero? cp][
			either str/value > FFFFh [
				cp: cp - 00010000h						;-- encode surrogate pair
				putwchar cp >> 10 + D800h				;-- emit lead
				putwchar cp and 03FFh + DC00h			;-- emit trail
			][
				putwchar cp								;-- UCS-2 codepoint
			]
			str: str + 1
		]
	]

	;-------------------------------------------
	;-- Print a UCS-4 string to console
	;-------------------------------------------
	print-line-UCS4: func [
		str    [int-ptr!]								;-- zero-terminated UCS-4 string
		/local
			cp [integer!]								;-- codepoint
	][
		assert str <> null
		print-UCS4 str									;@@ throw an error on failure
		putwchar 10										;-- newline
	]

	;-------------------------------------------
	;-- Print a UCS-2 string to console
	;-------------------------------------------
	print-UCS2: func [
		str 	[byte-ptr!]								;-- zero-terminated UCS-2 string
	][
		assert str <> null
		wprintf str										;@@ throw an error on failure
	]

	;-------------------------------------------
	;-- Print a UCS-2 string with newline to console
	;-------------------------------------------
	print-line-UCS2: func [
		str 	[byte-ptr!]								;-- zero-terminated UCS-2 string
	][
		assert str <> null
		wprintf str										;@@ throw an error on failure
		putwchar 10										;-- newline
	]

	;-------------------------------------------
	;-- Print a Latin-1 string to console
	;-------------------------------------------
	print-Latin1: func [
		str 	[c-string!]								;-- zero-terminated Latin-1 string
		/local
			cp [integer!]								;-- codepoint
	][
		assert str <> null

		while [cp: as-integer str/1 not zero? cp][
			putwchar cp
			str: str + 1
		]
	]

	;-------------------------------------------
	;-- Print a Latin-1 string with newline to console
	;-------------------------------------------
	print-line-Latin1: func [
		str [c-string!]									;-- zero-terminated Latin-1 string
	][
		assert str <> null
		print-Latin1 str
		putwchar 10										;-- newline
	]

	;-------------------------------------------
	;-- Red/System Unicode replacement printing functions
	;-------------------------------------------

	prin: func [s [c-string!] return: [c-string!] /local p][
		p: s
		while [p/1 <> null-byte][
			putwchar as-integer p/1
			p: p + 1
		]
		s
	]

	prin-int: func [i [integer!] return: [integer!]][
		wprintf ["%^(00)i^(00)^(00)" i]								;-- UTF-16 literal string
		i
	]

	prin-hex: func [i [integer!] return: [integer!]][
		wprintf ["%^(00)0^(00)8^(00)X^(00)^(00)" i]					;-- UTF-16 literal string
		i
	]

	prin-float: func [f [float!] return: [float!]][
		wprintf ["^(00)%^(00).^(00)1^(00)4^(00)g^(00)^(00)" f]		;-- UTF-16 literal string
		f
	]

	prin-float32: func [f [float32!] return: [float32!]][
		wprintf ["^(00)%^(00).^(00)7^(00)g^(00)^(00)" as-float f]	;-- UTF-16 literal string
		f
	]

	;-------------------------------------------
	;-- Do platform-specific initialization tasks
	;-------------------------------------------
	init: does [
		#if unicode? = yes [
			_setmode fd-stdout _O_U16TEXT				;@@ throw an error on failure
			_setmode fd-stderr _O_U16TEXT				;@@ throw an error on failure
		]
	]
]

Red/System [
	Title:   "Red runtime win32 API imported functions definitions"
	Author:  "Nenad Rakocevic"
	File: 	 %win32.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt
	}
]

#define VA_COMMIT_RESERVE	3000h						;-- MEM_COMMIT | MEM_RESERVE
#define VA_PAGE_RW			04h							;-- PAGE_READWRITE
#define VA_PAGE_RWX			40h							;-- PAGE_EXECUTE_READWRITE

#define _O_TEXT        	 	4000h  						;-- file mode is text (translated)
#define _O_BINARY       	8000h  						;-- file mode is binary (untranslated)
#define _O_WTEXT        	00010000h 					;-- file mode is UTF16 (translated)
#define _O_U16TEXT      	00020000h 					;-- file mode is UTF16 no BOM (translated)
#define _O_U8TEXT       	00040000h 					;-- file mode is UTF8  no BOM (translated)

platform: context [

	#enum file-descriptors! [
		fd-stdout: 1									;@@ hardcoded, safe?
		fd-stderr: 2									;@@ hardcoded, safe?
	]

	page-size: 4096

	#import [
		LIBC-file cdecl [
			putwchar: "putwchar" [
				wchar		[integer!]					;-- wchar is 16-bit on Windows
			]
			wprintf: "wprintf_s" [
				[variadic]
				return: 	[integer!]
			]
			_setmode: "_setmode" [
				handle		[integer!]
				mode		[integer!]
				return:		[integer!]
			]
			;_open_osfhandle: "_open_osfhandle" [
			;	handle		[integer!]
			;	flags		[integer!]
			;	return:		[integer!]
			;]
		]
		"kernel32.dll" stdcall [
			VirtualAlloc: "VirtualAlloc" [
				address		[byte-ptr!]
				size		[integer!]
				type		[integer!]
				protection	[integer!]
				return:		[int-ptr!]
			]
			VirtualFree: "VirtualFree" [
				address 	[int-ptr!]
				size		[integer!]
				return:		[integer!]
			]
		]
	]

	;-------------------------------------------
	;-- Allocate paged virtual memory region from OS
	;-------------------------------------------
	allocate-virtual: func [
		size 	[integer!]								;-- allocated size in bytes (page size multiple)
		exec? 	[logic!]								;-- TRUE => executable region
		return: [int-ptr!]								;-- allocated memory region pointer
		/local ptr prot
	][
		prot: either exec? [VA_PAGE_RWX][VA_PAGE_RW]

		ptr: VirtualAlloc
			null
			size
			VA_COMMIT_RESERVE
			prot

		if ptr = null [
			raise-error RED_ERR_VMEM_OUT_OF_MEMORY 0
		]
		ptr
	]

	;-------------------------------------------
	;-- Free paged virtual memory region from OS
	;-------------------------------------------
	free-virtual: func [
		ptr [int-ptr!]									;-- address of memory region to release
	][
		if negative? VirtualFree ptr ptr/value [
			raise-error RED_ERR_VMEM_RELEASE_FAILED as-integer ptr
		]
	]

	;-------------------------------------------
	;-- Print a UCS-4 string to console
	;-------------------------------------------
	print-UCS4: func [
		str    [int-ptr!]								;-- zero-terminated UCS-4 string
		/local
			cp [integer!]								;-- codepoint
	][
		assert str <> null

		while [cp: str/value not zero? cp][
			either str/value > FFFFh [
				cp: cp - 00010000h						;-- encode surrogate pair
				putwchar cp >> 10 + D800h				;-- emit lead
				putwchar cp and 03FFh + DC00h			;-- emit trail
			][
				putwchar cp								;-- UCS-2 codepoint
			]
			str: str + 1
		]
	]

	;-------------------------------------------
	;-- Print a UCS-4 string to console
	;-------------------------------------------
	print-line-UCS4: func [
		str    [int-ptr!]								;-- zero-terminated UCS-4 string
		/local
			cp [integer!]								;-- codepoint
	][
		assert str <> null
		print-UCS4 str									;@@ throw an error on failure
		putwchar 10										;-- newline
	]

	;-------------------------------------------
	;-- Print a UCS-2 string to console
	;-------------------------------------------
	print-UCS2: func [
		str 	[byte-ptr!]								;-- zero-terminated UCS-2 string
	][
		assert str <> null
		wprintf str										;@@ throw an error on failure
	]

	;-------------------------------------------
	;-- Print a UCS-2 string with newline to console
	;-------------------------------------------
	print-line-UCS2: func [
		str 	[byte-ptr!]								;-- zero-terminated UCS-2 string
	][
		assert str <> null
		wprintf str										;@@ throw an error on failure
		putwchar 10										;-- newline
	]

	;-------------------------------------------
	;-- Print a Latin-1 string to console
	;-------------------------------------------
	print-Latin1: func [
		str 	[c-string!]								;-- zero-terminated Latin-1 string
		/local
			cp [integer!]								;-- codepoint
	][
		assert str <> null

		while [cp: as-integer str/1 not zero? cp][
			putwchar cp
			str: str + 1
		]
	]

	;-------------------------------------------
	;-- Print a Latin-1 string with newline to console
	;-------------------------------------------
	print-line-Latin1: func [
		str [c-string!]									;-- zero-terminated Latin-1 string
	][
		assert str <> null
		print-Latin1 str
		putwchar 10										;-- newline
	]

	;-------------------------------------------
	;-- Red/System Unicode replacement printing functions
	;-------------------------------------------

	prin: func [s [c-string!] return: [c-string!] /local p][
		p: s
		while [p/1 <> null-byte][
			putwchar as-integer p/1
			p: p + 1
		]
		s
	]

	prin-int: func [i [integer!] return: [integer!]][
		wprintf ["%^(00)i^(00)^(00)" i]								;-- UTF-16 literal string
		i
	]

	prin-hex: func [i [integer!] return: [integer!]][
		wprintf ["%^(00)0^(00)8^(00)X^(00)^(00)" i]					;-- UTF-16 literal string
		i
	]

	prin-float: func [f [float!] return: [float!]][
		wprintf ["^(00)%^(00).^(00)1^(00)4^(00)g^(00)^(00)" f]		;-- UTF-16 literal string
		f
	]

	prin-float32: func [f [float32!] return: [float32!]][
		wprintf ["^(00)%^(00).^(00)7^(00)g^(00)^(00)" as-float f]	;-- UTF-16 literal string
		f
	]

	;-------------------------------------------
	;-- Do platform-specific initialization tasks
	;-------------------------------------------
	init: does [
		_setmode fd-stdout _O_U16TEXT					;@@ throw an error on failure
		_setmode fd-stderr _O_U16TEXT					;@@ throw an error on failure
	]
]


TESTS: a few more basic namespace tests

TESTS: a few more basic namespace tests

Red/System [
	Title:   "Red/System null test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %namespace-test.reds
	Rights:  "Copyright (C) 2011 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~~~ "namespace"

    nmsp1: context [
      i: 123
      f: 1.23
      f32: as float32! 2.46
      l: true
      s: "my string"
      fn: func [pi [pointer! [integer!]]] [pi/value: 789]
      fn2: func [
        i [integer!]
        return: [integer!]
      ][ 2 * i]
      st: declare struct! [
        a [integer!]
        b [integer!]
      ]
    ]

===start-group=== "basic"

  --test-- "ns1"
  --assert 123 = nmsp1/i
  --test-- "ns2"
  --assert 1.23 = nmsp1/f
  --test-- "ns3"
  --assert (as float32! 2.46) = nmsp1/f32
  --test-- "ns4"
  --assert nmsp1/l
  --test-- "ns5"
    nmsp1/s: "hello"
  --assert 5 = length? nmsp1/s
  --test-- "ns6"
  --assert nmsp1/s/1 = #"m"
  --assert nmsp1/s/1 = #"y"
  --assert nmsp1/s/1 = #" "
  --assert nmsp1/s/1 = #"s"
  --assert nmsp1/s/1 = #"t"
  --assert nmsp1/s/1 = #"r"
  --assert nmsp1/s/1 = #"i"
  --assert nmsp1/s/1 = #"n"
  --assert nmsp1/s/1 = #"g"
  --test-- "ns7"
    ns1-b-i: 0
  --assert 789 = nmsp1/fn :ns1-b-i
  --test-- "ns8"
    ns1-b-i: 4
  --assert 8 = nmsp1/fn2 ns1-b-i
  --test-- "ns9"
    nmsp1/st/a: 1
  --assert nmsp1/st/a = 1

===end-group===

===start-group=== "hiding"
    i: 321
    f: 3.21
    f32: as float32! 6.42
    l: false
    s: "not my string"
    fn: func [pi [pointer! [integer!]]] [pi/value: 987]
    fn2: func[
        i [integer!]
        return: [integer!]
      ][ 3 * i]
    st: declare struct! [
        a [integer!]
        b [integer!]
    ]

  --test-- "nmh1"
    nmsp1/i: 789
  --assert i = 321
  --test-- "nmh2"
    nmsp1/f: 7.89
  --assert f = 3.21
  --test "nmh3"
    nmsp1/f32: as float32! 7.89
  --assert f32! = as float32! 3.21
  --test "nmh4"
    nmsp1/s: "str"
  --assert 13 = length? s
  --test "nmh5"
    nmh5-i: 1
    nmsp1/fn :nmh5-1
  --assert 789 = nmh5-i
  --test "nmh6"
    nmh6-i: 1
    fn :nmh6-i
  --assert 987 = nmh5-1
  --test "nmh7"
    nmh7-i: 2
  --assert 4 = nmsp1/fn2 nmh7-i
  --assert 6 = fn2 nmh7-i
  --test "nmh8"
    st/a: 1
    st/b: 2
    nmsp1/st/a: 100
    nmsp1/st/b: 200
  --assert 1 = st/a
  --assert 2 = st/b

===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System null test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %namespace-test.reds
	Rights:  "Copyright (C) 2011 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~~~ "namespace"

    nmsp1: context [
      i: 123
      f: 1.23
      f32: as float32! 2.46
      l: true
      s: "my string"
      fn: func [pi [pointer! [integer!]]] [pi/value: 789]
      fn2: func [
        i [integer!]
        return: [integer!]
      ][ 2 * i]
      st: declare struct! [
        a [integer!]
        b [integer!]
      ]
    ]

===start-group=== "basic"

  --test-- "ns1"
  --assert 123 = nmsp1/i
  --test-- "ns2"
  --assert 1.23 = nmsp1/f
  --test-- "ns3"
  --assert (as float32! 2.46) = nmsp1/f32
  --test-- "ns4"
  --assert nmsp1/l
  --test-- "ns5"
    nmsp1/s: "hello"
  --assert 5 = length? nmsp1/s
  --test-- "ns6"
  --assert nmsp1/s/1 = #"m"
  --assert nmsp1/s/1 = #"y"
  --assert nmsp1/s/1 = #" "
  --assert nmsp1/s/1 = #"s"
  --assert nmsp1/s/1 = #"t"
  --assert nmsp1/s/1 = #"r"
  --assert nmsp1/s/1 = #"i"
  --assert nmsp1/s/1 = #"n"
  --assert nmsp1/s/1 = #"g"
  --test-- "ns7"
    ns1-b-i: 0
  --assert 789 = nmsp1/fn :ns1-b-i
  --test-- "ns8"
    ns1-b-i: 4
  --assert 8 = nmsp1/fn2 ns1-b-i
  --test-- "ns9"
    nmsp1/st/a: 1
  --assert nmsp1/st/a = 1

===end-group===

===start-group=== "hiding"
    i: 321
    f: 3.21
    f32: as float32! 6.42
    l: false
    s: "not my string"
    fn: func [pi [pointer! [integer!]]] [pi/value: 987]

  --test-- "nmh1"
    nmsp1/i: 789
  --assert i = 321

===end-group===

~~~end-file~~~


Fixing broken link to the contributors agreement

<% @sidebar = "sidebar_contributing" %>

h1. Contributing

Contributing to CruiseControl.rb boosts your self-esteem, improves your karma, looks good on your CV and generally
makes the world a happier place.

You can help in four different ways:
* report bugs
* create and publish your own plugins
* fix bugs and submit patches
* improve documentation

h2. Report bugs

CruiseControl.rb uses a public "bug tracker":http://cruisecontrolrb.lighthouseapp.com to keep track of bugs,
patches, ideas and development stories.

Before you can submit a bug, you need to
"create a Lighthouse account":http://cruisecontrolrb.lighthouseapp.com/users/new for yourself. This way we protect
the tracker against spam and make sure that we can get in touch with you if we have questions (or answers).

Please try to be as specific as possible about the symptoms and likely root causes of the problem, include
screenshots, stack traces, quotes from log files or any other relevant information. Do not neglect
"reading the fine manual":/documentation/manual, and consulting the
"troubleshooting guide":/documentation/troubleshooting for some useful debugging / evidence gathering techniques.

Also, please try to make sure that the problem is in CruiseControl.rb, not in your build or CI configuration. It can be
quite embarrassing to go through a long chain of emails, and learn at the end of it that it was your problem and you
could have easily figured it out yourself.

h2. Create plugins

CruiseControl.rb design philosophy can be summarized as "be simple, and people will come to you". Of course, many
an open-source project started this way, and ended up as a truckload of half-heartedly implemented features. We have no
intention whatsoever to fall into that trap.

This is why CruiseControl is trying to satisfy the basic needs of its primary audience (which is small to medium size
Ruby projects), while providing enough opportunity for extending and hacking the tool without affecting the
sweet simplicity of the core codebase.

Ruby, of course, is an interpreted language with open classes that lets you do anything you want.
Remember: with great powers come great dangers. The next version of CruiseControl.rb may
simply be incompatible with your black belt hackery. Be wise and constrain yourself to interface points
designed for pluggability.

CruiseControl.rb has a few of these.

h3. Dashboard plugins

Dashboard is a regular Rails application, that can be extended through the regular
Rails
"plugins":http://www.agilewebdevelopment.com/plugins/index
"infrastructure.":http://www.tutorialized.com/tutorial/HOWTO-Make-a-Rails-Plugin-From-Scratch/19055
"Enough said.":http://nubyonrails.com/articles/2006/05/04/the-complete-guide-to-rails-plugins-part-i

h3. Builder plugins

While checking source control for new revisions, building, or handling errors, a builder generates events. Anyone can
write a listener for those events.

To know the types of events a builder sends to its listeners, look at implementation and usages of
Project#notify()
method.

For an example of a working plugin, look at [cruise]/lib/builder_plugins/email_notifier.rb or
[cruise]/lib/builder_plugins/jabber_notifier. Note that a plugin can be implemented as a single file, or a
directory (containing init.rb). Either way, the file or directory name should match the class name of the listener
class, and the plugin should be placed in [cruise]/lib/builder_plugins directory.

It would be good to have more documentation here, as well as some guarantees about published API for plugins, but it's
too early to make such commitments. Let's build some great plugins, and see what kind of API evolves in the process.
It's a fair bet that build_finished, build_fixed and build_broken will always be there, have access to
Build and Project instances, and know location of the build artifacts directory for the build in question.

h3. Custom Rake tasks

Surely, if there is a CI tool for Ruby, its capabilities can be greatly enhanced by writing cool Rake tasks and
sharing them with the world.

For example, how about deploying an app to another box via Capistrano, running a battery of Selenium tests against it,
then pulling back test results and placing them in CC_BUILD_ARTIFACTS directory?

Or perhaps a much simpler task that is invoked in the end of a successful unit test build, and creates a "build now"
request for the Big Bang Selenium build described above?

h3. Custom schedulers

Scheduler is an object responsible for telling a Project when to build itself.
At the moment, we only have one kind of a scheduler: a PollingScheduler, which simply tells the builder every so often
to check if source control has new revisions. You can write your own scheduler and inject it into the project through
a configuration file: project.scheduler = AstrologyAwareScheduler.new(current_phase_of_the_moon)

h2. Submit patches

We absolutely love receiving bug reports. Who doesn't, after all? But what can make us really happy is a bug
report coming with a patch that fixes the bug and adds unit tests to prevent it from ever happening again.
Contributing a well packaged patch that is accepted into the codebase places your name for posterity in
CruiseControl.rb Eternal Hall of Fame, aka the CHANGELOG.

Official Standard Procedure for the Submission of Patches is hereby defined as follows:

1. Check out the latest source from the git repository:

git clone git://github.com/thoughtworks/cruisecontrol.rb.git

2. Run the build, make sure that it passes: rake

3. Make changes to the source. Don't forget the unit tests.

4. Run the build again, make sure that it still passes.

p(hint). Besides, your tests should not leave any by-products in the file system. If you need to create a file in your
         test, use in_sandbox() or with_sandbox_project() test helpers.

5. Commit changes into your local git repository.

5. Check that Git is fully aware of files you added/deleted/renamed, using git stat

6. Create a patch with git-format-patch

7. Login to "Lighthouse":http://cruisecontrolrb.lighthouseapp.com

8. Create a new issue, prefix the summary with the word [PATCH].

9. Keep in touch by monitoring the issue. Think about joining the
   <%= link_to_developers_mailing_list 'cruisecontrolrb-developers mailing list'%>.

Also, when we're ready to apply the patch, we'll send you an e-mail that looks like "this":contributors_agreement which we'll need a reply to for legal reasons.

h2. Improve documentation

Believe it or not, but we value contributions to end user documentation as much as (if not more than) we value patches.

Documentation for CruiseControl.rb is included in the release package, as files under
the [cruise]/app/views/documentation directory. When you connect to CruiseControl.rb dashboard running on your computer
and click the Documentation link in the top right corner, its the content of those files that you see.

Packaging documentation with release makes sure that you are always looking at documentation for the same version
that you are running. It also makes it easy to submit documentation patches. Simply follow the aforementioned
Procedure for source code patches.

The *.red files are written in a mixture of "Textile":http://hobix.com/textile and HTML markup. The best way to edit
these files is to run CruiseControl.rb dashboard from your local checked out copy of the trunk, in development mode:

./cruise start -e development.

Any change that you make to a documentation file can be seen in the
browser as soon as you hit the Refresh button.

h2. Copyright considerarions

CruiseControl.rb is developed by "ThoughtWorks":http://www.thoughtworks.com.
ThoughtWorks is an IT consultancy, and we built this tool primarily because our own project
teams need it (these days, we do a lot of Ruby work).

It is distributed under a free open-source "license":/documentation/license. However, ThoughtWorks wants to ensure
that ownership of the codebase remains clear. So, if you want to contribute code to CruiseControl.rb, and you don't work
for ThoughtWorks (by the way, is there any good reason why you don't?), we will ask you to share ownership of your
contributions to us. This is not some sort of evil world domination scheme, just a legal precaution. Apache Software
Foundation, in fact, does "something similar":http://www.apache.org/licenses/icla.txt.

<% @sidebar = "sidebar_contributing" %>

h1. Contributing

Contributing to CruiseControl.rb boosts your self-esteem, improves your karma, looks good on your CV and generally
makes the world a happier place.

You can help in four different ways:
* report bugs
* create and publish your own plugins
* fix bugs and submit patches
* improve documentation

h2. Report bugs

CruiseControl.rb uses a public "bug tracker":http://cruisecontrolrb.lighthouseapp.com to keep track of bugs,
patches, ideas and development stories.

Before you can submit a bug, you need to
"create a Lighthouse account":http://cruisecontrolrb.lighthouseapp.com/users/new for yourself. This way we protect
the tracker against spam and make sure that we can get in touch with you if we have questions (or answers).

Please try to be as specific as possible about the symptoms and likely root causes of the problem, include
screenshots, stack traces, quotes from log files or any other relevant information. Do not neglect
"reading the fine manual":/documentation/manual, and consulting the
"troubleshooting guide":/documentation/troubleshooting for some useful debugging / evidence gathering techniques.

Also, please try to make sure that the problem is in CruiseControl.rb, not in your build or CI configuration. It can be
quite embarrassing to go through a long chain of emails, and learn at the end of it that it was your problem and you
could have easily figured it out yourself.

h2. Create plugins

CruiseControl.rb design philosophy can be summarized as "be simple, and people will come to you". Of course, many
an open-source project started this way, and ended up as a truckload of half-heartedly implemented features. We have no
intention whatsoever to fall into that trap.

This is why CruiseControl is trying to satisfy the basic needs of its primary audience (which is small to medium size
Ruby projects), while providing enough opportunity for extending and hacking the tool without affecting the
sweet simplicity of the core codebase.

Ruby, of course, is an interpreted language with open classes that lets you do anything you want.
Remember: with great powers come great dangers. The next version of CruiseControl.rb may
simply be incompatible with your black belt hackery. Be wise and constrain yourself to interface points
designed for pluggability.

CruiseControl.rb has a few of these.

h3. Dashboard plugins

Dashboard is a regular Rails application, that can be extended through the regular
Rails
"plugins":http://www.agilewebdevelopment.com/plugins/index
"infrastructure.":http://www.tutorialized.com/tutorial/HOWTO-Make-a-Rails-Plugin-From-Scratch/19055
"Enough said.":http://nubyonrails.com/articles/2006/05/04/the-complete-guide-to-rails-plugins-part-i

h3. Builder plugins

While checking source control for new revisions, building, or handling errors, a builder generates events. Anyone can
write a listener for those events.

To know the types of events a builder sends to its listeners, look at implementation and usages of
Project#notify()
method.

For an example of a working plugin, look at [cruise]/lib/builder_plugins/email_notifier.rb or
[cruise]/lib/builder_plugins/jabber_notifier. Note that a plugin can be implemented as a single file, or a
directory (containing init.rb). Either way, the file or directory name should match the class name of the listener
class, and the plugin should be placed in [cruise]/lib/builder_plugins directory.

It would be good to have more documentation here, as well as some guarantees about published API for plugins, but it's
too early to make such commitments. Let's build some great plugins, and see what kind of API evolves in the process.
It's a fair bet that build_finished, build_fixed and build_broken will always be there, have access to
Build and Project instances, and know location of the build artifacts directory for the build in question.

h3. Custom Rake tasks

Surely, if there is a CI tool for Ruby, its capabilities can be greatly enhanced by writing cool Rake tasks and
sharing them with the world.

For example, how about deploying an app to another box via Capistrano, running a battery of Selenium tests against it,
then pulling back test results and placing them in CC_BUILD_ARTIFACTS directory?

Or perhaps a much simpler task that is invoked in the end of a successful unit test build, and creates a "build now"
request for the Big Bang Selenium build described above?

h3. Custom schedulers

Scheduler is an object responsible for telling a Project when to build itself.
At the moment, we only have one kind of a scheduler: a PollingScheduler, which simply tells the builder every so often
to check if source control has new revisions. You can write your own scheduler and inject it into the project through
a configuration file: project.scheduler = AstrologyAwareScheduler.new(current_phase_of_the_moon)

h2. Submit patches

We absolutely love receiving bug reports. Who doesn't, after all? But what can make us really happy is a bug
report coming with a patch that fixes the bug and adds unit tests to prevent it from ever happening again.
Contributing a well packaged patch that is accepted into the codebase places your name for posterity in
CruiseControl.rb Eternal Hall of Fame, aka the CHANGELOG.

Official Standard Procedure for the Submission of Patches is hereby defined as follows:

1. Check out the latest source from the git repository:

git clone git://github.com/thoughtworks/cruisecontrol.rb.git

2. Run the build, make sure that it passes: rake

3. Make changes to the source. Don't forget the unit tests.

4. Run the build again, make sure that it still passes.

p(hint). Besides, your tests should not leave any by-products in the file system. If you need to create a file in your
         test, use in_sandbox() or with_sandbox_project() test helpers.

5. Commit changes into your local git repository.

5. Check that Git is fully aware of files you added/deleted/renamed, using git stat

6. Create a patch with git-format-patch

7. Login to "Lighthouse":http://cruisecontrolrb.lighthouseapp.com

8. Create a new issue, prefix the summary with the word [PATCH].

9. Keep in touch by monitoring the issue. Think about joining the
   <%= link_to_developers_mailing_list 'cruisecontrolrb-developers mailing list'%>.

Also, when we're ready to apply the patch, we'll send you an e-mail that looks like "this":contributors_agreement.html
which we'll need a reply to for legal reasons.

h2. Improve documentation

Believe it or not, but we value contributions to end user documentation as much as (if not more than) we value patches.

Documentation for CruiseControl.rb is included in the release package, as files under
the [cruise]/app/views/documentation directory. When you connect to CruiseControl.rb dashboard running on your computer
and click the Documentation link in the top right corner, its the content of those files that you see.

Packaging documentation with release makes sure that you are always looking at documentation for the same version
that you are running. It also makes it easy to submit documentation patches. Simply follow the aforementioned
Procedure for source code patches.

The *.red files are written in a mixture of "Textile":http://hobix.com/textile and HTML markup. The best way to edit
these files is to run CruiseControl.rb dashboard from your local checked out copy of the trunk, in development mode:

./cruise start -e development.

Any change that you make to a documentation file can be seen in the
browser as soon as you hit the Refresh button.

h2. Copyright considerarions

CruiseControl.rb is developed by "ThoughtWorks":http://www.thoughtworks.com.
ThoughtWorks is an IT consultancy, and we built this tool primarily because our own project
teams need it (these days, we do a lot of Ruby work).

It is distributed under a free open-source "license":/documentation/license. However, ThoughtWorks wants to ensure
that ownership of the codebase remains clear. So, if you want to contribute code to CruiseControl.rb, and you don't work
for ThoughtWorks (by the way, is there any good reason why you don't?), we will ask you to share ownership of your
contributions to us. This is not some sort of evil world domination scheme, just a legal precaution. Apache Software
Foundation, in fact, does "something similar":http://www.apache.org/licenses/icla.txt.


fixed bugs in control client

fixed bugs in control client

Red [
	Title:		"MONICA ZeroMQ control client"
	Author:		"Michael Berg-Mohnicke"
	Rights:		"Copyright (C) Leibniz Centre for Agricultural Landscape Research (ZALF)"
	License: {
		This Source Code Form is subject to the terms of the Mozilla Public
		License, v. 2.0. If a copy of the MPL was not distributed with this
		file, You can obtain one at http://mozilla.org/MPL/2.0/.
	}
	Needs: 'View
	;Needs*: {
	;	Red >= 0.4.3
	;	%ZeroMQ-binding.red
	;}
	Based-on: "ZeroMQ request/reply client example by Kaj de Vos"
	Tabs:		4
]

#include %../../../sys-libs/red/ZeroMQ-binding/ZeroMQ-binding.red

;prin ["0MQ version:" major-version]
;	prin #"."  prin minor-version
;	prin #"."  print patch-version
;prin newline

timeout-ms: 3000
use-timeouts: false
set-timeouts: function [socket][
	set-integer socket send-timeout timeout-ms
	set-integer socket receive-timeout timeout-ms
]

defaults: [
	proxy-address "localhost"
	proxy-frontend-port 5555
	proxy-backend-port 5566
	control-address "tcp://localhost:8888"
	publisher-control-address "tcp://localhost:8899"
	input-address "tcp://localhost:6666"
	output-address "tcp://localhost:7777"
	service-port 6666
]

;address: any [get-argument 1 tcp://localhost:8888]
stop-msg-template: {{"type": "finish"}}
stop-pub-msg-template: {finish{"type": "finish"}}

control-stop-msg-template: {
	{	"type": "finish"
	,	"count": <count>
	}
}

service-msg-template: {
	{	"type": "<type>"
	,	"count": <count>
	,	"control-addresses": "<control-addresses>"
	,	"service-port": <service-port>
	}
}

proxy-msg-template: {
	{	"type": "<type>"
	,	"count": <count>
	,	"control-addresses": "<control-addresses>"
	,	"proxy-address": "<proxy-address>"
	, 	"proxy-frontend-port": <proxy-frontend-port>
	,	"proxy-backend-port": <proxy-backend-port>
	}
}

pipeline-msg-template: {
	{	"type": "<type>"
	,	"count": <count>
	,	"control-addresses": "<control-addresses>"
	,	"input-addresses": "<input-addresses>"
	,	"output-addresses": "<output-addresses>"
	}
}

log-error: does [  ; FIXME: should go to stderr
	;print ["system-error: " system-error]
	print form-error system-error
]

log?: false
log: function [out][
	if log? [print out]
]

send-msg: function [socket msg][
	log ["Sending request"]

	either send socket msg [
		log ["Sent message: " msg]
	][
		log-error
	]
]

receive-msg: function [socket /debug][
	data: ""

	log ["Receiving msg"]

	either receive/over socket data [
		log ["Received message: " data]
	][
		log-error
	]
	data
]

comment {
#system [
	i: 1
	;pi: declare pointer! [integer!]
	pi: :i
	#define h! [pointer! [integer!]]

	i!: alias struct! [d [integer!]]
	si: declare i!

	si/d: 2

	print ["i: " i " pi: " pi " pi as i!: " as i! pi " si: " si " si as h!: " as h! si]

	h: 0
	hs: "0xFF"
	success: parse-hex hs :h
	print ["success?: " success " hs: " hs " h: " h]

]
}

def: function ['k][
	;print k
	v: select defaults k
	either any [
		(type? v) = string!
		v = none
	] [v] [to string! v]
]

replace-multi: function [template multi][
	t: copy template
	foreach [k v] multi [replace t k v v]
	t
]

connect-to: function [address cf dcf][
	either connect socket address [
		cf/enable?: false
		dcf/enable?: true
	][
		log-error
		cf/enable?: false
		dcf/enable?: true
	]
]

disconnect-from: function [cf dcf][
	lep: get-string socket last-endpoint
	either all [
		not empty? lep
		disconnect socket lep
	][
		cf/enable?: true
		dcf/enable?: false
	][
		;log-error
		cf/enable?: true
		dcf/enable?: false
	]
]

stop: function [address count][
	either zero? stopSocket: open-socket pool request! [
		log-error
	][
		if use-timeouts [set-timeouts stopSocket]

		loop count [
			either connect stopSocket address [
				send-msg stopSocket stop-msg-template
				receive-msg stopSocket
				disconnect stopSocket get-string stopSocket last-endpoint
			][
				log-error
			]
		]
	]
	unless close-socket stopSocket [log-error]
]

stop-via-pub: function [port][
	either zero? stopSocket: open-socket pool publish! [
		log-error
	][
		if use-timeouts [set-timeouts stopSocket]

		address: replace-multi "tcp://127.0.0.1:port" reduce ["port" port]

		either serve stopSocket address [
			;print "now waiting to publish finish message"
			wait 2 ;wait 2 seconds for subscribers to connect

			send-msg stopSocket stop-pub-msg-template

			if not unbind stopSocket get-string stopSocket last-endpoint [log-error]
		][
			log-error
		]
	]
	unless close-socket stopSocket [log-error]
]

either zero? pool: make-pool 1 [
	log-error
][
	either zero? socket: open-socket pool request! [
		log-error
	][
		if use-timeouts [set-timeouts socket]

		view compose/deep [
			title: "MONICA ZeroMQ control client"

			across
			text "Control node address:" control-address: field 150 (def control-address)
			return

			check "Use timeouts" data (use-timeouts) [
				if use-timeouts: face/data [set-timeouts socket]
			]
			con: button "connect" [connect-to control-address/text con discon]
			discon: button "disconnect" disabled [disconnect-from con discon]
			return

			type: drop-down "start-new" data ["start-new" "start-max" "stop"] select 1
			count: field "1" text "MONICA instances"
			return

			text "Publisher control address(es):" pub-control-addresses: field 150 (def publisher-control-address)
			return

			below
			tp: tab-panel [
				"Pipeline" [
					across
					text "Input address(es):" input-addresses: field 150 (def input-address)
					return
					text "Output address(es):" output-addresses: field 150 (def output-address)
					return
					button "action" react [face/text: type/text face/enable?: not con/enable?] [
						;print input-addresses/text
						m: replace-multi pipeline-msg-template reduce [
							"<type>" type/text
							"<count>" to integer! count/data
							"<control-addresses>" pub-control-addresses/text
							"<input-addresses>" input-addresses/text
							"<output-addresses>" output-addresses/text
						]
						;print m
						send-msg socket m
						receive-msg socket
					]
					button "stop" [
						stop-via-pub to integer! first parse pub-control-addresses/text [
							collect [some ["tcp://" thru ":" keep [to "," | thru end] opt ","]]
						]
					]
				]
				"Proxy" [
					across
					text "Proxy address:" proxy-address: field (def proxy-address)
					text "frontend-port:" frontend-port: field (def proxy-frontend-port)
					text "backend-port:" backend-port: field (def proxy-backend-port)
					return
					button "action" react [face/text: type/text face/enable?: not con/enable?] [
						m: replace-multi proxy-msg-template reduce [
							"<type>" type/text
							"<count>" to integer! count/data
							"<control-address>" pub-control-addresses/text
							"<proxy-address>" proxy-address/text
							"<proxy-frontend-port>" to integer! frontend-port/data
							"<proxy-backend-port>" to integer! backend-port/data
						]
						send-msg socket m
						receive-msg socket
					]
					button "stop" [
						stop proxy-address/text to integer! frontend-port/data to integer! count/data
					]
				]
				"Single-service" [
					across
					text "Service port:" service-port: field (def service-port)
					return
					button "action" react [face/text: type/text face/enable?: not con/enable?] [
						m: replace-multi service-msg-template reduce [
							"<type>" type/text
							"<count>" to integer! count/data
							"<control-address>" pub-control-addresses/text
							"<service-port>" to integer! service-port/data
						]
						send-msg socket m
						receive-msg socket
					]
					button "stop" [
						stop control-address/text to integer! service-port/data 1
					]
				]
			]
			do [
				;connect-to control-address/text control-port/text con discon
				self/actors: object [on-close: func [f e] [
					disconnect-from con discon
				]]
			]
		]
		unless close-socket socket [log-error]
	]
	unless end-pool pool [log-error]
]

Red [
	Title:		"MONICA ZeroMQ control client"
	Author:		"Michael Berg-Mohnicke"
	Rights:		"Copyright (C) Leibniz Centre for Agricultural Landscape Research (ZALF)"
	License: {
		This Source Code Form is subject to the terms of the Mozilla Public
		License, v. 2.0. If a copy of the MPL was not distributed with this
		file, You can obtain one at http://mozilla.org/MPL/2.0/.
	}
	Needs: 'View
	;Needs*: {
	;	Red >= 0.4.3
	;	%ZeroMQ-binding.red
	;}
	Based-on: "ZeroMQ request/reply client example by Kaj de Vos"
	Tabs:		4
]

#include %../../../sys-libs/red/ZeroMQ-binding/ZeroMQ-binding.red

;prin ["0MQ version:" major-version]
;	prin #"."  prin minor-version
;	prin #"."  print patch-version
;prin newline

timeout-ms: 3000
use-timeouts: false
set-timeouts: function [socket][
	set-integer socket send-timeout timeout-ms
	set-integer socket receive-timeout timeout-ms
]

defaults: [
	proxy-address "localhost"
	proxy-frontend-port 5555
	proxy-backend-port 5566
	control-address "tcp://localhost:8888"
	publisher-control-address "tcp://localhost:8899"
	input-address "tcp://localhost:6666"
	output-address "tcp://localhost:7777"
	service-port 6666
]

;address: any [get-argument 1 tcp://localhost:8888]
stop-msg-template: {{"type": "finish"}}
stop-pub-msg-template: {finish{"type": "finish"}}

control-stop-msg-template: {
	{	"type": "finish"
	,	"count": <count>
	}
}

service-msg-template: {
	{	"type": <type>
	,	"count": <count>
	,	"control-addresses": <control-addresses>
	,	"service-port": <service-port>
	}
}

proxy-msg-template: {
	{	"type": <type>
	,	"count": <count>
	,	"control-addresses": <control-addresses>
	,	"proxy-address": <proxy-address>
	, 	"proxy-frontend-port": <proxy-frontend-port>
	,	"proxy-backend-port": <proxy-backend-port>
	}
}

pipeline-msg-template: {
	{	"type": <type>
	,	"count": <count>
	,	"control-addresses": <control-addresses>
	,	"input-addresses": <input-addresses>
	,	"output-addresses": <output-addresses>
	}
}

log-error: does [  ; FIXME: should go to stderr
	;print ["system-error: " system-error]
	print form-error system-error
]

log?: false
log: function [out][
	if log? [print out]
]

send-msg: function [socket msg][
	log ["Sending request"]

	either send socket msg [
		log ["Sent message: " msg]
	][
		log-error
	]
]

receive-msg: function [socket /debug][
	data: ""

	log ["Receiving msg"]

	either receive/over socket data [
		log ["Received message: " data]
	][
		log-error
	]
	data
]

comment {
#system [
	i: 1
	;pi: declare pointer! [integer!]
	pi: :i
	#define h! [pointer! [integer!]]

	i!: alias struct! [d [integer!]]
	si: declare i!

	si/d: 2

	print ["i: " i " pi: " pi " pi as i!: " as i! pi " si: " si " si as h!: " as h! si]

	h: 0
	hs: "0xFF"
	success: parse-hex hs :h
	print ["success?: " success " hs: " hs " h: " h]

]
}

def: function ['k][
	print k
	v: select defaults k
	either any [
		(type? v) = string!
		v = none
	] [v] [to string! v]
]

replace-multi: function [template multi /mold*][
	t: copy template
	foreach [k v] multi [replace t k either mold* [mold v] [v]]
	t
]

connect-to: function [address cf dcf][
	either connect socket address [
		cf/enable?: false
		dcf/enable?: true
	][
		log-error
		cf/enable?: false
		dcf/enable?: true
	]
]

disconnect-from: function [cf dcf][
	lep: get-string socket last-endpoint
	either all [
		not empty? lep
		disconnect socket lep
	][
		cf/enable?: true
		dcf/enable?: false
	][
		;log-error
		cf/enable?: true
		dcf/enable?: false
	]
]

stop: function [address count][
	either zero? stopSocket: open-socket pool request! [
		log-error
	][
		if use-timeouts [set-timeouts stopSocket]

		loop count [
			either connect stopSocket address [
				send-msg stopSocket stop-msg-template
				receive-msg stopSocket
				disconnect stopSocket get-string stopSocket last-endpoint
			][
				log-error
			]
		]
	]
	unless close-socket stopSocket [log-error]
]

stop-via-pub: function [port][
	either zero? stopSocket: open-socket pool publish! [
		log-error
	][
		if use-timeouts [set-timeouts stopSocket]

		address: replace-multi "tcp://127.0.0.1:port" reduce ["port" port]

		either serve stopSocket address [
			;print "now waiting to publish finish message"
			wait 2 ;wait 2 seconds for subscribers to connect

			send-msg stopSocket stop-pub-msg-template

			if not unbind stopSocket get-string stopSocket last-endpoint [log-error]
		][
			log-error
		]
	]
	unless close-socket stopSocket [log-error]
]

either zero? pool: make-pool 1 [
	log-error
][
	either zero? socket: open-socket pool request! [
		log-error
	][
		if use-timeouts [set-timeouts socket]

		view compose/deep [
			title: "MONICA ZeroMQ control client"

			across
			text "Control node address:" control-address: field 150 (def control-address)
			return

			check "Use timeouts" data (use-timeouts) [
				if use-timeouts: face/data [set-timeouts socket]
			]
			con: button "connect" [connect-to control-address/text con discon]
			discon: button "disconnect" disabled [disconnect-from con discon]
			return

			type: drop-down "start-new" data ["start-new" "start-max" "stop"] select 1
			count: field "1" text "MONICA instances"
			return

			text "Publisher control address(es):" pub-control-addresses: field 150 (def publisher-control-address)
			return

			below
			tp: tab-panel [
				"Pipeline" [
					across
					text "Input address(es):" input-addresses: field 150 (def input-address)
					return
					text "Output address(es):" output-addresses: field 150 (def output-address)
					return
					button "action" react [face/text: type/text face/enable?: not con/enable?] [
						m: replace-multi/mold* pipeline-msg-template reduce [
							"<type>" type/text
							"<count>" to integer! count/data
							"<control-addresses>" pub-control-addresses/text
							"<input-addresses>" input-addresses/text
							"<output-addresses>" output-addresses/text
						]
						send-msg socket m
						receive-msg socket
					]
					button "stop" [
						stop-via-pub to integer! first parse pub-control-address/text [
							collect [some ["tcp://" thru ":" keep [to "," | thru end] opt ","]]
						]
					]
				]
				"Proxy" [
					across
					text "Proxy address:" proxy-address: field (def proxy-address)
					text "frontend-port:" frontend-port: field (def proxy-frontend-port)
					text "backend-port:" backend-port: field (def proxy-backend-port)
					return
					button "action" react [face/text: type/text face/enable?: not con/enable?] [
						m: replace-multi/mold* proxy-msg-template reduce [
							"<type>" type/text
							"<count>" to integer! count/data
							"<control-address>" pub-control-addresses/text
							"<proxy-address>" proxy-address/text
							"<proxy-frontend-port>" to integer! frontend-port/data
							"<proxy-backend-port>" to integer! backend-port/data
						]
						send-msg socket m
						receive-msg socket
					]
					button "stop" [
						stop proxy-address/text to integer! frontend-port/data to integer! count/data
					]
				]
				"Single-service" [
					across
					text "Service port:" service-port: field (def service-port)
					return
					button "action" react [face/text: type/text face/enable?: not con/enable?] [
						m: replace-multi/mold* service-msg-template reduce [
							"<type>" type/text
							"<count>" to integer! count/data
							"<control-address>" pub-control-addresses/text
							"<service-port>" to integer! service-port/data
						]
						send-msg socket m
						receive-msg socket
					]
					button "stop" [
						stop control-address/text to integer! service-port/data 1
					]
				]
			]
			do [
				;connect-to control-address/text control-port/text con discon
				self/actors: object [on-close: func [f e] [
					disconnect-from con discon
				]]
			]
		]
		unless close-socket socket [log-error]
	]
	unless end-pool pool [log-error]
]