# Copyright 2011  Petter Urkedal
#
# This file is part of the Viz Standard Library <http://www.vizlang.org/>.
#
# The Viz Standard Library (VSL) is free software: you can redistribute it
# and/or modify it under the terms of the GNU Lesser General Public License as
# published by the Free Software Foundation, either version 3 of the License,
# or (at your option) any later version.
#
# The VSL is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public License for
# more details.
#
# You should have received a copy of the GNU Lesser General Public License
# along with the VSL.  If not, see <http://www.gnu.org/licenses/>.

open prereq
open effect

in extend_basic_numeric.(basic_numeric : a_basic_numeric)
    open basic_numeric

    let two be add one one

    let _ipow a n
	let mul_pow a n accu
	    if n = 0 be accu
	    let accu' be int.bitand 1 n = 0 ⇒ accu; mul accu a
	    be mul_pow (mul a a) (int.shift -1 n) accu'
	if a = one be one
	if int.2'≥ n 0 be mul_pow a n one
	if a = zero fail "ipow: division by zero"
	be zero

    let _iloga a x
	let iloga' a
	    if x < a be (x, 0)
	    let sqr_a be mul a a
	    if sqr_a ≤ a be (x, 0)
	    let (x', y) be iloga' sqr_a
	    if x' < a be (x', int.mul y 2)
	    be (0'div x' a, int.add (int.mul y 2) 1)
	be snd (iloga' a)

in extend_basic_nat_or_int.(basic_nat : a_basic_nat)
    open compat.ocaml_miscints
    open basic_nat
    include extend_basic_numeric.(basic_nat)

    let ipow be _ipow

    let iloga a x
	if a ≤ one fail "iloga requires a base greater than one."
	be _iloga a x

    let min x y be x ≤ y ⇒ x; y
    let max x y be x ≤ y ⇒ y; x

    let floor_log2 x
	let f iL width
	    if int.eq width 1 be iL
	    let halfwidth be int.shift -1 width
	    let iM be int.add iL halfwidth
	    be f iL halfwidth if eq zero (shift (int.neg iM) x)
	    be f iM (int.sub width halfwidth) otherwise
	if x <= zero fail "Non-positive value passed to floor_log2."
	be f 0 width

    let _digits be "0123456789abcdefghijklmnopqrstuvwxyz"

    let _show pfx a x
	if x = zero be "0"
	be observe (that : ∀ψ. effect ψ α) which!
	    let buf do string.buf.create
	    do string.buf.put_string buf pfx
	    let! loop z when z ≠ zero
		let y be as_int (0'rem (0'quo x z) a)
		do string.buf.put_char buf (string.get y _digits)
		do loop (0'quo z a)
	    do loop (ipow a (iloga a x))
	    do string.buf.contents buf

in extend_basic_nat.(basic_nat : a_basic_nat)
    open basic_nat
    include extend_basic_nat_or_int.(basic_nat)

    in ops include nat_ops.(basic_nat)
    open ops

    let cdiv x y be (x + y - one) div y

    let show base:*?(of_int 10) x be _show "" base x

    let see base:a?(of_int 10) s
	let n be string.length s
	let i be string.skip_space s 0
	if i = n be none
	let loop j x
	    if j = n be some x
	    taken char.digit_value (as_int a) (string.get j s)
	    at none%
		if string.skip_space s j = n be some x
		be none
	    at some c be loop (int.add j 1) (x * a + (of_int c))
	be loop 0 zero

in extend_basic_int.(basic_int : a_basic_int)
    open basic_int
    include extend_basic_nat_or_int.(basic_int)

    in ops include int_ops.(basic_int)
    open ops

    let cdiv x y be - x div (- y)
    let cmod x y be   x mod (- y)

    let show base:*?(of_int 10) x
	if x ≥ zero be _show "" base x
	if x > minimum be _show "-" base (abs x)
	let s be _show "-" base (abs (0'quo x base))
	be _show s base (abs (0'rem x base))

    let see base:a?(of_int 10) s
	let n be string.length s
	let i' be string.skip_space s 0
	if i' = n be none
	let i, pm if string.get i' s ≠ c"-" be i', 1
		  be int.add i' 1, -1
	if i = n be none
	let loop j x
	    if j = n be some x
	    taken char.digit_value (as_int a) (string.get j s)
	    at none%
		if string.skip_space s j = n be some x
		be none
	    at some c be loop (int.add j 1) (x * a + (of_int (int.mul pm c)))
	be loop 0 zero

in extend_basic_float.(basic_float : a_basic_float)
    open basic_float
    include extend_basic_numeric.(basic_float)

    let one_half be 0'div one two

    let ipow a n
	if int.2'≥ n 0 be _ipow a n
	be _ipow (0'div one a) (int.neg n)

    let iloga a x
	if a ≤ zero fail "The fist argument of iloga must be positive."
	if x ≤ zero fail "The second argument of iloga must be positive."
	if a > one
	    if x > one be _iloga a x
	    be int.neg (_iloga a (0'div one x))
	if a < one
	    if x < one be _iloga (0'div one a) (0'div one x)
	    be int.neg (_iloga (0'div one a) x)
	fail "iloga requires a base in (0, 1) ∪ (1, ∞)."

    in ops
	let 1'+. (x : t) be x
	let 2'+. be add
	let 1'−. be neg
	let 2'−. be sub
	let 2'×. be mul
	let 2'∕. be 0'div

in pervasive
    #?ffoc open compat.ocaml_miscints
    in int
	include int
	include extend_basic_int.(int)
    in nint
	include nint
	include extend_basic_int.(nint)
    in nnat
	include nnat
	include extend_basic_nat.(nnat)
    in int32
	include int32
	include extend_basic_int.(int32)
    in int64
	include int64
	include extend_basic_int.(int64)
    in nat32
	include nat32
	include extend_basic_nat.(nat32)
    in nat64
	include nat64
	include extend_basic_nat.(nat64)
    in float
	include float
	include extend_basic_float.(float)