(***********************************************************************)
(*                                                                     *)
(*                         Applied Type System                         *)
(*                                                                     *)
(*                              Hongwei Xi                             *)
(*                                                                     *)
(***********************************************************************)

(*
 * ATS - Unleashing the Power of Types!
 *
 * Copyright (C) 2002-2007 Hongwei Xi, Boston University
 *
 * All rights reserved
 *
 * ATS is free software;  you can  redistribute it and/or modify it under
 * the  terms of the  GNU General Public License as published by the Free
 * Software Foundation; either version 2.1, or (at your option) any later
 * version.
 * 
 * ATS 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 General Public License
 * for more details.
 * 
 * You  should  have  received  a  copy of the GNU General Public License
 * along  with  ATS;  see the  file COPYING.  If not, please write to the
 * Free Software Foundation,  51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301, USA.
 *
 *)

(* ****** ****** *)

(* author: Hongwei Xi (hwxi AT cs DOT bu DOT edu) *)

(* ****** ****** *)

staload "ralist.sats"

datatype T (a:t@ype+, int) =
  | RAnil (a, 0)
  | RAone (a, 1) of a
  | {n:pos} RAevn (a, n+n) of (T (a, n), T (a, n))
  | {n:pos} RAodd (a, n+n+1) of (T (a, n+1), T (a, n))

assume ralist (a:t@ype, n:int) = T (a, n)

(* ****** ****** *)

implement{a} ralist_length (xs) = case+ xs of
  | RAnil () => 0 | RAone _ => 1
  | RAevn (xs, _) => 2 * ralist_length (xs)
  | RAodd (_, ys) => 2 * ralist_length (ys) + 1
// end of [ralist_length]

(* ****** ****** *)

extern fun{a:t@ype} raevn {n:nat}
  (xs: ralist (a, n), ys: ralist (a, n)):<> ralist (a, n+n)

implement{a} raevn (xs, ys) = case+ xs of
  | RAnil () => ys | _ =>> RAevn (xs, ys)
// end of [raevn]

extern fun{a:t@ype} raodd {n:nat}
  (xs: ralist (a, n+1), ys: ralist (a, n)):<> ralist (a, n+n+1)

implement{a} raodd (xs, ys) = case+ xs of
  | RAone _ => xs | _ =>> RAodd (xs, ys)
// end of [raodd]

(* ****** ****** *)

implement{a} ralist_cons (x, xs) = case+ xs of
  | RAnil () => RAone x
  | RAone _ => RAevn (RAone x, xs)
  | RAevn (ys, zs) => RAodd (ralist_cons (x, zs), ys)
  | RAodd (ys, zs) => RAevn (ralist_cons (x, zs), ys)
// end of [ralist_cons]

(* ****** ****** *)

implement{a} ralist_head (xs) = case+ xs of
  | RAone x => x
  | RAevn (xs, _) => ralist_head xs
  | RAodd (xs, _) => ralist_head xs
// end of [ralist_head]

implement{a} ralist_head_exn (xs) = case+ xs of
  | RAnil () => begin
      $raise RandomAccessListSubscriptException ()
    end
  | _ =>> ralist_head xs
// end of [ralist_head_exn]

(* ****** ****** *)

implement{a} ralist_tail (xs) = case+ xs of
  | RAone _ => RAnil
  | RAevn (xs, ys) => raodd (ys, ralist_tail xs)
  | RAodd (xs, ys) => raevn (ys, ralist_tail xs)
// end of [ralist_tail]

implement{a} ralist_tail_exn (xs) = case+ xs of
  | RAnil () => begin
      $raise RandomAccessListSubscriptException ()
    end
  | _ =>> ralist_tail xs
// end of [ralist_tail_exn]

(* ****** ****** *)

implement{a} ralist_uncons (xs) = case+ xs of
  | RAone x => (x, RAnil ())
  | RAevn (xs, ys) => let
      val (x, xs') = ralist_uncons xs
    in
      (x, raodd (ys, xs'))
    end
  | RAodd (xs, ys) => let
      val (x, xs') = ralist_uncons xs
    in
      (x, raevn (ys, xs'))
    end
// end of [ralist_uncons]


implement{a} ralist_uncons_exn (xs) = case+ xs of
  | RAnil () => begin
      $raise RandomAccessListSubscriptException ()
    end
  | _ =>> ralist_uncons xs
// end of [ralist_uncons_exn]

(* ****** ****** *)

implement{a} ralist_snoc (x, xs) = case+ xs of
  | RAnil () => RAone x
  | RAone _ => RAevn (xs, RAone x)
  | RAevn (ys, zs) => RAodd (ralist_snoc (x, ys), zs)
  | RAodd (ys, zs) => RAevn (ys, ralist_snoc (x, zs))
// end of [ralist_snoc]

implement{a} ralist_last (xs) = case+ xs of
  | RAone x => x
  | RAevn (_, ys) => ralist_last ys
  | RAodd (xs, _) => ralist_last xs
// end of [ralist_last]

implement{a} ralist_last_exn (xs) = case+ xs of
  | RAnil () => begin
      $raise RandomAccessListSubscriptException ()
    end
  | _ =>> ralist_last xs
// end of [ralist_last_exn]

(* ****** ****** *)

implement{a} ralist_init (xs) = case+ xs of
  | RAone x => RAnil
  | RAevn (xs, ys) => raodd (xs, ralist_init ys)
  | RAodd (xs, ys) => raevn (ralist_init xs, ys)
// end of [ralist_init]

implement{a} ralist_init_exn (xs) = case+ xs of
  | RAnil () => begin
      $raise RandomAccessListSubscriptException ()
    end
  | _ =>> ralist_init xs
// end of [ralist_init_exn]

(* ****** ****** *)

implement{a} ralist_unsnoc (xs) = case+ xs of
  | RAone x => (RAnil (), x)
  | RAevn (xs, ys) => let
      val (ys, y) = ralist_unsnoc ys
    in
       (raodd (xs, ys), y)
    end
  | RAodd (xs, ys) => let
      val (xs, x) = ralist_unsnoc xs
    in
      (raevn (xs, ys), x)
    end
// end of [ralist_unsnoc]

implement{a} ralist_unsnoc_exn (xs) = case+ xs of
  | RAnil () => begin
      $raise RandomAccessListSubscriptException ()
    end
  | xs =>> ralist_unsnoc xs
// end of [ralist_unsnoc_exn]

(* ****** ****** *)

implement{a} ralist_lookup (xs, i) = case+ xs of
  | RAone x => x
  | RAevn (xs, ys) => begin
      if i nmod 2 = 0 then ralist_lookup (xs, nhalf i)
      else ralist_lookup (ys, nhalf i)
    end // end of [if]
  | RAodd (xs, ys) => begin
      if i nmod 2 = 0 then ralist_lookup (xs, nhalf i)
      else ralist_lookup (ys, nhalf i)
    end // end of [if]
// end of [ralist_lookup]

implement{a} ralist_lookup_exn (xs, i) =
  if i < ralist_length xs then begin
    ralist_lookup (xs, i)
  end else begin
    $raise RandomAccessListSubscriptException ()
  end // end of [if]
// end of [ralist_lookup_exn]

(* ****** ****** *)

implement{a} ralist_update (xs, i, x) = case+ xs of
  | RAone _ => RAone x
  | RAevn (xs, ys) =>
      if i nmod 2 = 0 then begin
        RAevn (ralist_update (xs, nhalf i, x), ys)
      end else begin
        RAevn (xs, ralist_update (ys, nhalf i, x))
      end
    // end of [RAevn]
  | RAodd (xs, ys) =>
      if i nmod 2 = 0 then begin
        RAodd (ralist_update (xs, nhalf i, x), ys)
      end else begin
        RAodd (xs, ralist_update (ys, nhalf i, x))
      end
   // end of [RAodd]
// end of [ralist_update]

implement{a} ralist_update_exn (xs, i, x) =
  if i < ralist_length xs then begin
    ralist_update (xs, i, x)
  end else begin
    $raise RandomAccessListSubscriptException ()
  end // end of [if]
// end of [ralist_update_exn]

(* ****** ****** *)

(* end of [ralist.dats] *)