Add implements of bits_uint_lor, bits_uint_land, make_single_bit and bits_uint_not.

(*
**
** A template for single-file ATS programs
**
*)

(* ****** ****** *)
//
#include "share/atspre_define.hats"
#include "share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"
staload "Bit.sats"

//
(* ****** ****** *)

//
// please write you program in this section
//

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

implement main0 () = () // a dummy implementation for [main]

prfn {n:int} le_refl   ():[n <= n]     void = ()

primplement beqint_is_nat {n,v}{bs} (beqint_fst)
 = let
     prfun aux {n,v:int}{bs:bits} .<bs>. (beqint:BITSEQINT (n,bs,v)):[0 <= v] void =
       case+ beqint of
       | BEQNIL   ()       => le_refl ()   // 0 <= 0
       | BEQCONS (beqind,B0EQ0 ()) => aux (beqind) // (0 <= n) -> (0 <= n+0)
       | BEQCONS (beqind,B1EQ1 ()) => aux (beqind) // (0 <= n) -> (0 <= n+1)
   in aux (beqint_fst) end

prfn {b:bit}{v:int} beqint_nat2 (beqint:BITEQINT (b,v)):[0 <= v][v <= 1] void
 = case+ beqint of
   | B0EQ0 () => ()
   | B1EQ1 () => ()

prfn {b:bit} beq0__b_is_O (beqint:BITEQINT (b,0)):[O == b] void
 = case+ beqint of
   | B0EQ0 () =>   bit_eq_refl {b}()
   | B1EQ1 () =/=> ()

prfn {b:bit} beq1__b_is_I (beqint:BITEQINT (b,1)):[I == b] void
 = case+ beqint of
   | B0EQ0 () =/=> ()
   | B1EQ1 () =>   bit_eq_refl {b}()

primplement bits_test1 () = BEQNIL()
primplement bits8_test2 () =
  BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQNIL,B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0)
primplement bits8_test3 () =
  BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQNIL,B1EQ1),B1EQ1),B1EQ1),B1EQ1),B1EQ1),B1EQ1),B1EQ1),B1EQ1)
primplement bits8_test4_1 () = BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQNIL,B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B1EQ1)
primplement bits8_test4_2 () = BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQNIL,B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B1EQ1),B0EQ0)
primplement bits8_test4_3 () = BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQNIL,B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B1EQ1),B0EQ0),B0EQ0)
primplement bits8_test4_4 () = BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQNIL,B0EQ0),B0EQ0),B0EQ0),B0EQ0),B1EQ1),B0EQ0),B0EQ0),B0EQ0)
primplement bits8_test4_5 () = BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQNIL,B0EQ0),B0EQ0),B0EQ0),B1EQ1),B0EQ0),B0EQ0),B0EQ0),B0EQ0)
primplement bits8_test4_6 () = BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQNIL,B0EQ0),B0EQ0),B1EQ1),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0)
primplement bits8_test4_7 () = BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQNIL,B0EQ0),B1EQ1),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0)
primplement bits8_test4_8 () = BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQNIL,B1EQ1),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0)

primplement bitscons0_eq_double     {bs}{n,v} (bitseq) = BEQCONS (bitseq,B0EQ0)
primplement bitscons0_eq__cons1_inc {bs}{n,v} (bitseq) = let prval BEQCONS (bitseq',B0EQ0 ()) = bitseq in BEQCONS (bitseq',B1EQ1) end

primplement chgbit_test1 () = CHANGE_BIT_BITS_bas (BITSLENNIL)
primplement chgbit_test2 () =
  CHANGE_BIT_BITS_ind (CHANGE_BIT_BITS_ind (CHANGE_BIT_BITS_ind (CHANGE_BIT_BITS_ind (
  CHANGE_BIT_BITS_ind (CHANGE_BIT_BITS_ind (CHANGE_BIT_BITS_ind (CHANGE_BIT_BITS_bas (BITSLENNIL))))))))
primplement chgbit_test3 () = CHANGE_BIT_BITS_bas (
  BITSLENCONS (BITSLENCONS (BITSLENCONS (BITSLENCONS (
  BITSLENCONS (BITSLENCONS (BITSLENCONS (BITSLENNIL))))))))

prfun bitseqint__bitslen {n,v:int}{bs:bits} .<bs>.
      (bseqint:BITSEQINT (n,bs,v)):BITSLEN (bs,n)
 = case+ bseqint of
   | BEQNIL ()                 => BITSLENNIL ()
   | BEQCONS (bseqint',beqint) => BITSLENCONS (bitseqint__bitslen (bseqint'))

prfn double_v_plus_bit__injective
        {b,c:bit}{v,w,bv,cw:int | v+v+bv==w+w+cw}
        (beqbv:BITEQINT (b,bv),ceqcw:BITEQINT (c,cw)):[v==w && bv==cw] void
 = case+ (beqbv,ceqcw) of
   | (B0EQ0 (),B0EQ0 ()) => ()
   | (B1EQ1 (),B1EQ1 ()) => ()
   | (B0EQ0 (),B1EQ1 ()) =/=> ()
   | (B1EQ1 (),B0EQ0 ()) =/=> ()

prfn beqint_injective {b,c:bit}{v:int}
                      (beqv:BITEQINT (b,v),ceqv:BITEQINT (c,v)):[b==c] void
 = case+ (beqv,ceqv) of
   | (B0EQ0 (),B0EQ0 ()) => bit_eq_refl {O}()
   | (B1EQ1 (),B1EQ1 ()) => bit_eq_refl {I}()
   | (B0EQ0 (),B1EQ1 ()) =/=> ()
   | (B1EQ1 (),B0EQ0 ()) =/=> ()

prfun eqint__bs_eq_cs {n,v:int}{bs,cs:bits} .<bs>.
      (bseqv:BITSEQINT (n,bs,v),cseqv:BITSEQINT (n,cs,v)):[bs==cs] void
 = case+ (bseqv,cseqv) of
   | (BEQNIL (),BEQNIL ()) => bits_eq_refl {BitsNil}()
   | (BEQNIL (),BEQCONS (cs'eqv',ceqcv)) =/=>
         bitslen_nat (bitseqint__bitslen (cs'eqv'))
   | (BEQCONS (bs'eqv',beqbv),BEQNIL ()) =/=>
         bitslen_nat (bitseqint__bitslen (bs'eqv'))
   | (BEQCONS {n'}{b}{bs'}{v',bv}(bs'eqv',beqbv),
      BEQCONS {m'}{c}{cs'}{w',cw}(cs'eqw',ceqcw)) => let
         prval () = double_v_plus_bit__injective
                      {b,c}{v',w',bv,cw}(beqbv,ceqcw)
         prval () = beqint_injective {b,c}{bv}(beqbv,ceqcw)
         prval () = eqint__bs_eq_cs {n',v'}{bs',cs'}(bs'eqv',cs'eqw')
         prval EQBIT () = eqbit_make {b,c}()
         prval EQBITS () = eqbits_make {bs',cs'}()
       in bits_eq_refl {bs}() end

primplement chgbit_test4 {bs,cs}(bseq0,cseq1)
 = let
     prval BEQCONS {n'}{b}{bs'}{v',bv}(bs'eq0, b'eq0) = bseq0
     prval BEQCONS {m'}{c}{cs'}{w',cv}(cs'eq0, c'eq1) = cseq1
     prval B0EQ0 () = b'eq0
     prval B1EQ1 () = c'eq1
     prval BEQCONS (BEQCONS (BEQCONS (BEQCONS (
           BEQCONS (BEQCONS (BEQCONS (BEQNIL
           ,B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0) = bs'eq0
     prval BEQCONS (BEQCONS (BEQCONS (BEQCONS (
           BEQCONS (BEQCONS (BEQCONS (BEQNIL
           ,B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0) = cs'eq0
     prval () = eqint__bs_eq_cs (bs'eq0,cs'eq0)
     prval EQBITS () = eqbits_make {bs',cs'}()
     prval bs'len = bitseqint__bitslen (bs'eq0)
   in CHANGE_BIT_BITS_bas (bs'len) end

prfn bseqint_len_is_nat {bs:bits}{n,v:int}(bseqv:BITSEQINT (n,bs,v)):[0<=n] void
 = bitslen_nat (bitseqint__bitslen (bseqv))

primplement chgbit_test5 {bs,cs}(bseq0,cseq128)
 = case+ (bseq0,cseq128) of
    | (_,BEQCONS (_,B1EQ1 ())) =/=> ()
    | (BEQCONS (_,B1EQ1 ()),_) =/=> ()
    | (BEQCONS (_,B0EQ0 ()),
       BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ())) =/=> ()
    | (BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()),
       BEQCONS (_,B0EQ0 ())) =/=> ()
    | (BEQCONS (BEQCONS (_,B0EQ0 ()),B0EQ0 ()),
       BEQCONS (BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()),B0EQ0 ())) =/=> ()
    | (BEQCONS (BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()),B0EQ0 ()),
       BEQCONS (BEQCONS (_,B0EQ0 ()),B0EQ0 ())) =/=> ()
    | (BEQCONS (BEQCONS (BEQCONS (_,B0EQ0 ()),B0EQ0 ()),B0EQ0 ()),
       BEQCONS (BEQCONS (BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()),B0EQ0 ()),B0EQ0 ())) =/=> ()
    | (BEQCONS (BEQCONS (BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()),B0EQ0 ()),B0EQ0 ()),
       BEQCONS (BEQCONS (BEQCONS (_,B0EQ0 ()),B0EQ0 ()),B0EQ0 ())) =/=> ()
    | (BEQCONS (BEQCONS (BEQCONS (BEQCONS (bs_eq0,B0EQ0 ()),B0EQ0 ()),B0EQ0 ()),B0EQ0 ()),
       BEQCONS (BEQCONS (BEQCONS (BEQCONS (cs_eq4,B0EQ0 ()),B0EQ0 ()),B0EQ0 ()),B0EQ0 ())) => let
      in case+ (bs_eq0,cs_eq4) of
          | (_,BEQCONS (_,B1EQ1 ())) =/=> ()
          | (BEQCONS (_,B1EQ1 ()),_) =/=> ()
          | (BEQCONS (_,B0EQ0 ()),
             BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ())) =/=> ()
          | (BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()),
             BEQCONS (_,B0EQ0 ())) =/=> ()
          | (BEQCONS (BEQCONS (_,B0EQ0 ()),B0EQ0 ()),
             BEQCONS (BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()),B0EQ0 ())) =/=> ()
          | (BEQCONS (BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()),B0EQ0 ()),
             BEQCONS (BEQCONS (_,B0EQ0 ()),B0EQ0 ())) =/=> ()
          | (BEQCONS (BEQCONS (BEQCONS (bs'eq0,B0EQ0 ()),B0EQ0 ()),B0EQ0 ()),
             BEQCONS (BEQCONS (BEQCONS (cs'eq1,B0EQ0 ()),B0EQ0 ()),B0EQ0 ())) => let
            in case+ (bs'eq0,cs'eq1) of
                | (BEQCONS (bs''eq0,B1EQ1 ()),_) =/=> ()
                | (_,BEQCONS (cs''eq0,B0EQ0 ())) =/=> ()
                | (BEQCONS (bs''eq0,B0EQ0 ()),BEQCONS (cs''eq0,B1EQ1 ())) => let
                  in case+ (bs''eq0,cs''eq0) of
                    | (BEQCONS (bs'''eq0,_),_) =/=> bseqint_len_is_nat (bs'''eq0)
                    | (_,BEQCONS (cs'''eq0,_)) =/=> bseqint_len_is_nat (cs'''eq0)
                    | (BEQNIL (), BEQNIL ()) =>
                      CHANGE_BIT_BITS_ind (CHANGE_BIT_BITS_ind (CHANGE_BIT_BITS_ind (
                      CHANGE_BIT_BITS_ind (CHANGE_BIT_BITS_ind (CHANGE_BIT_BITS_ind (
                      CHANGE_BIT_BITS_ind (CHANGE_BIT_BITS_bas (BITSLENNIL)))))))) end end end

primplement tstbit_test1 () = let
		prval () = bit_eq_refl {I}()
  in TEST_BIT_BITS_bas {0}{I}{BitsNil}(BITSLENNIL) end
primplement tstbit_test2 () = let
		prval () = bit_eq_refl {O}()
  in TEST_BIT_BITS_bas {0}{O}{BitsNil}(BITSLENNIL) end
primplement tstbit_test3 () = let
    prval bslen = BITSLENCONS (BITSLENCONS (BITSLENCONS (BITSLENCONS (
          BITSLENCONS (BITSLENCONS (BITSLENCONS (BITSLENNIL)))))))
  in TEST_BIT_BITS_bas (bslen) end
primplement tstbit_test4 ()
 = TEST_BIT_BITS_ind (TEST_BIT_BITS_ind (TEST_BIT_BITS_ind (
   TEST_BIT_BITS_ind (TEST_BIT_BITS_ind (TEST_BIT_BITS_ind (
   TEST_BIT_BITS_ind (TEST_BIT_BITS_bas (BITSLENNIL))))))))

primplement tstbit_test5 () = let
    prval bslen = BITSLENCONS (BITSLENCONS (BITSLENCONS (BITSLENCONS (BITSLENNIL))))
  in TEST_BIT_BITS_ind (TEST_BIT_BITS_ind (TEST_BIT_BITS_ind (
     TEST_BIT_BITS_bas (bslen)))) end

primplement tstbit_test6 () = let
    prval bslen = BITSLENCONS (BITSLENCONS (BITSLENCONS (BITSLENNIL)))
  in TEST_BIT_BITS_ind (TEST_BIT_BITS_ind (TEST_BIT_BITS_ind (
     TEST_BIT_BITS_ind (TEST_BIT_BITS_bas (bslen))))) end

primplement tstbit_test7 {bs}(bseq1) = let
    prval BEQCONS (bs'eq0,B1EQ1 ()) = bseq1
  in case+ bs'eq0 of
     | BEQCONS (_,B1EQ1 ()) =/=> ()
     | BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()) =/=> ()
     | BEQCONS (BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()),B0EQ0 ()) =/=> ()
     | BEQCONS (BEQCONS (BEQCONS (bs''eq0,B0EQ0 ()),B0EQ0 ()),B0EQ0 ()) =>
       case+ bs''eq0 of
       | BEQCONS (_,B1EQ1 ()) =/=> ()
       | BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()) =/=> ()
       | BEQCONS (BEQCONS (bs'''eq0,B0EQ0 ()),B0EQ0 ()) =>
         case+ bs'''eq0 of
         | BEQCONS (_,B1EQ1 ()) =/=> ()
         | BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()) =/=> ()
         | BEQCONS (BEQCONS (bsnileq0,B0EQ0 ()),B0EQ0 ()) =>
           case+ bsnileq0 of
           | BEQCONS (bsminuseq0,_) =/=> let
               prval () = bseqint_len_is_nat (bsminuseq0)
             in end
           | BEQNIL () => TEST_BIT_BITS_bas (bitseqint__bitslen (bs'eq0))
  end

//prfun tstbit_test8 {bs:bits}(BITSEQINT (8,bs,127)):TEST_BIT_BITS (bs,7,O)
primplement tstbit_test8 {bs}(bseq127)
 = case+ bseq127 of
     | BEQCONS (_,B0EQ0 ()) =/=> ()
     | BEQCONS (BEQCONS (_,B0EQ0 ()),B1EQ1 ()) =/=> ()
     | BEQCONS (BEQCONS (BEQCONS (_,B0EQ0 ()),B1EQ1 ()),B1EQ1 ()) =/=> ()
     | BEQCONS (BEQCONS (BEQCONS (bs'eq15,B1EQ1 ()),B1EQ1 ()),B1EQ1 ()) =>
       case+ bs'eq15 of
       | BEQCONS (_,B0EQ0 ()) =/=> ()
       | BEQCONS (BEQCONS (_,B0EQ0 ()),B1EQ1 ()) =/=> ()
       | BEQCONS (BEQCONS (BEQCONS (_,B0EQ0 ()),B1EQ1 ()),B1EQ1 ()) =/=> ()
       | BEQCONS (BEQCONS (BEQCONS (bs''eq3,B1EQ1 ()),B1EQ1 ()),B1EQ1 ()) =>
         case+ bs''eq3 of
         | BEQCONS (_,B0EQ0 ()) =/=> ()
         | BEQCONS (BEQCONS (_,B1EQ1 ()),B1EQ1 ()) =/=> ()
         | BEQCONS (BEQCONS (bsnileq0,B0EQ0 ()),B1EQ1 ()) =>
           case+ bsnileq0 of
           | BEQCONS (bsminuseq0,_) =/=> let
               prval () = bseqint_len_is_nat (bsminuseq0)
             in end
           | BEQNIL () =>
             TEST_BIT_BITS_ind (TEST_BIT_BITS_ind (TEST_BIT_BITS_ind (
             TEST_BIT_BITS_ind (TEST_BIT_BITS_ind (TEST_BIT_BITS_ind (
             TEST_BIT_BITS_ind (TEST_BIT_BITS_bas (BITSLENNIL))))))))

//prfun singlebit_test1 (): SINGLE_BIT_BITS (1,0,BitsCons (I,BitsNil))
primplement singlebit_test1 () = SINGLE_BIT_BITS_bas (BEQNIL)

//prfun singlebit_test2 (): SINGLE_BIT_BITS (2,1,BitsCons (O,BitsCons (I,BitsNil)))
primplement singlebit_test2 () = SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_bas (BEQNIL))

//prfun singlebit_test3 (): SINGLE_BIT_BITS (8,0,Bits8 (O,O,O,O,O,O,O,I))
primplement singlebit_test3 ()
 = SINGLE_BIT_BITS_bas (
     BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (BEQCONS (
     BEQNIL,B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0))

//prfun singlebit_test4 (): SINGLE_BIT_BITS (8,7,Bits8 (I,O,O,O,O,O,O,O))
primplement singlebit_test4 ()
 = SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_ind (
   SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_ind (
   SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_bas (BEQNIL))))))))

//prfun singlebit_test5 {bs:bits}(BITSEQINT (8,bs,1)):SINGLE_BIT_BITS (8,0,bs)
primplement singlebit_test5 {bs}(bs8eq1)
 = case+ bs8eq1 of
   | BEQCONS (_,B0EQ0 ()) =/=> ()
   | BEQCONS (bs7eq0,B1EQ1 ()) => SINGLE_BIT_BITS_bas (bs7eq0)

//prfun singlebit_test6 {bs:bits}(BITSEQINT (8,bs,128)):SINGLE_BIT_BITS (8,7,bs)
primplement singlebit_test6 {bs}(bs8eq128)
 = case+ bs8eq128 of
   | BEQCONS (_,B1EQ1 ()) =/=> ()
   | BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()) =/=> ()
   | BEQCONS (BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()),B0EQ0 ()) =/=> ()
   | BEQCONS (BEQCONS (BEQCONS (bs5eq16,B0EQ0 ()),B0EQ0 ()),B0EQ0 ()) =>
     case+ bs5eq16 of
     | BEQCONS (_,B1EQ1 ()) =/=> ()
     | BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()) =/=> ()
     | BEQCONS (BEQCONS (BEQCONS (_,B1EQ1 ()),B0EQ0 ()),B0EQ0 ()) =/=> ()
     | BEQCONS (BEQCONS (BEQCONS (bs2eq2,B0EQ0 ()),B0EQ0 ()),B0EQ0 ()) =>
       case+ bs2eq2 of
       | BEQCONS (_,B1EQ1 ()) =/=> ()
       | BEQCONS (BEQCONS (_,B0EQ0 ()),B0EQ0 ()) =/=> ()
       | BEQCONS (BEQCONS (bs0eq0,B1EQ1 ()),B0EQ0 ()) =>
         case+ bs0eq0 of
         | BEQCONS (bsminuseq0,_) =/=> let
             prval () = bseqint_len_is_nat (bsminuseq0)
           in end
         | BEQNIL () => singlebit_test4 ()

prfun singlebit_to_bitslen {n,m:int}{bs:bits} .<bs>.
      (bssingle:SINGLE_BIT_BITS (n,m,bs)):BITSLEN (bs,n)
 = case+ bssingle of
   | SINGLE_BIT_BITS_bas (bs'eqv) => BITSLENCONS (bitseqint__bitslen (bs'eqv))
   | SINGLE_BIT_BITS_ind (bs'single) => BITSLENCONS (singlebit_to_bitslen(bs'single))

//prfun singlebit_test7 {bs:bits}(SINGLE_BIT_BITS (8,0,bs)):BITSEQINT (8,bs,1)
primplement singlebit_test7 {bs}(bs8single)
 = case+ bs8single of
   | SINGLE_BIT_BITS_ind (bs7single) =/=> let
       prval SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_ind (
             SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_ind (
             SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_ind (bsminussingle)))))))) = bs7single
     in bitslen_nat (singlebit_to_bitslen (bsminussingle)) end
   | SINGLE_BIT_BITS_bas (bs7eq0) => BEQCONS (bs7eq0,B1EQ1)

//prfun singlebit_test8 {bs:bits}(SINGLE_BIT_BITS (8,7,bs)):BITSEQINT (8,bs,128)
prfun singlebit_test8 {bs:bits}.<bs>.
      (bs8single:SINGLE_BIT_BITS (8,7,bs)):BITSEQINT (8,bs,128) = let
    prval SINGLE_BIT_BITS_ind (bs7single) = bs8single
    prval SINGLE_BIT_BITS_ind (bs6single) = bs7single
    prval SINGLE_BIT_BITS_ind (bs5single) = bs6single
    prval SINGLE_BIT_BITS_ind (bs4single) = bs5single
    prval SINGLE_BIT_BITS_ind (bs3single) = bs4single
    prval SINGLE_BIT_BITS_ind (bs2single) = bs3single
    prval SINGLE_BIT_BITS_ind (bs1single) = bs2single
  in case+ bs1single of
     | SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_ind (bsminussingle)) =/=>
         bitslen_nat (singlebit_to_bitslen (bsminussingle))
     | SINGLE_BIT_BITS_ind (SINGLE_BIT_BITS_bas (bsminuseq0)) =/=>
         bitslen_nat (bitseqint__bitslen (bsminuseq0))
     | SINGLE_BIT_BITS_bas (bs0eq0) =>
         BEQCONS (BEQCONS (BEQCONS (BEQCONS (
         BEQCONS (BEQCONS (BEQCONS (BEQCONS (bs0eq0,
         B1EQ1),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0),B0EQ0)
  end

prfn bits_cons_eq {b,c:bit | b == c}{bs,cs:bits | bs == cs} ()
                   :[BitsCons (bs,b) == BitsCons (cs,c)] void
 = let
     prval EQBIT ()  = eqbit_make {b,c} ()
     prval EQBITS () = eqbits_make {bs,cs} ()
   in bits_eq_refl {BitsCons (bs,b)} () end

prfn lor_0_nochange {b,c:bit} (lor_p:BIT_LOR (b,O,c)):[b == c] void
 = case+ lor_p of
   | BIT_LOR_II () =/=> () // I≠O
   | BIT_LOR_IO ()   => bit_eq_refl {I}() // I=I
   | BIT_LOR_OI () =/=> () // I≠O
   | BIT_LOR_OO ()   => bit_eq_refl {O}() // O=O

prfn lor_1_assign   {b,c:bit} (lor_p:BIT_LOR (b,I,c)):[I == c] void
 = case+ lor_p of
   | BIT_LOR_II ()   => bit_eq_refl {I}() // I=I
   | BIT_LOR_IO () =/=> () // O≠I
   | BIT_LOR_OI ()   => bit_eq_refl {I}() // I=I
   | BIT_LOR_OO () =/=> () // O≠I

prfun bitslor_0_nochange {n:int}{bs,cs,ds:bits} .<bs>.
      (lor_p:BITS_LOR (bs,cs,ds),eq0:BITSEQINT (n,cs,0)):[bs == ds] void
 = scase bs of
   | BitsNil ()       => let
       prval BITS_LOR_NIL () = lor_p
     in bits_eq_refl {BitsNil} () end // BitsNil = BitsNil
   | BitsCons (bs',b) => scase ds of
       | BitsCons (ds',d) => let
           prval BITS_LOR_CONS (blor,bslor)    = lor_p
           prval BEQCONS       (eq0',B0EQ0 ()) = eq0
           prval () = lor_0_nochange (blor)
           prval () = bitslor_0_nochange (bslor,eq0')
         in bits_cons_eq {b,d}{bs',ds'}() end
       | BitsNil () => case+ lor_p of
                       | BITS_LOR_NIL  ()    =/=> ()
                       | BITS_LOR_CONS (_,_) =/=> ()

prfun bitslor__eq_bitslen {bs,cs,ds:bits} .<bs>. (bsor:BITS_LOR (bs,cs,ds))
                          :[n:int] (BITSLEN (bs,n),BITSLEN (cs,n),BITSLEN (ds,n))
 = case+ bsor of
   | BITS_LOR_NIL  ()          => (BITSLENNIL,BITSLENNIL,BITSLENNIL)
   | BITS_LOR_CONS (bor,bs'or) => let
       prval (bs'len,cs'len,ds'len) = bitslor__eq_bitslen (bs'or)
     in (BITSLENCONS (bs'len),BITSLENCONS (cs'len),BITSLENCONS (ds'len)) end

prfun bitslen_injective {n,m:int}{bs:bits} .<bs>.
                        (len_n:BITSLEN (bs,n), len_m:BITSLEN (bs,m)):[n == m] void
 = scase bs of
   | BitsNil ()       => let
       prval BITSLENNIL () = len_n
       prval BITSLENNIL () = len_m
     in end
   | BitsCons (b,bs') => let
       prval BITSLENCONS (len_n') = len_n
       prval BITSLENCONS (len_m') = len_m
     in bitslen_injective (len_n',len_m') end

prfn {bs,cs:bits}{n,bn:int} chgbit_bit_eq {b,c:bit | b == c}
       (bs_chg_b_at_bn:CHANGE_BIT_BITS (n,bs,bn,b,cs)):
        CHANGE_BIT_BITS (n,bs,bn,c,cs)
 = let prval EQBIT () = eqbit_make {b,c}() in bs_chg_b_at_bn end

prfn change_bit_bits_eq {n,bn:int}{b,c:bit | b == c}{bs,cs,ds,es:bits | bs == ds; cs == es}
                        (chbits:CHANGE_BIT_BITS (n,bs,bn,b,cs)): CHANGE_BIT_BITS (n,ds,bn,c,es)
 = let
     prval EQBIT ()  = eqbit_make {b,c} ()
     prval EQBITS () = eqbits_make {bs,ds} ()
     prval EQBITS () = eqbits_make {cs,es} ()
   in chbits end

prfn bit_eq_comm {b,c:bit | b == c} ():[c == b] void
 = let prval EQBIT () = eqbit_make {b,c} () in bit_eq_refl {b} () end

prfn bits_eq_comm {bs,cs:bits | bs == cs} ():[cs == bs] void
 = let prval EQBITS () = eqbits_make {bs,cs} () in bits_eq_refl {bs} () end

prfun singlebitslor__changebit1 {n,bn:int}{bs,cs,ds:bits} .<bs>.
      (single:SINGLE_BIT_BITS (n,bn,cs),lor_p:BITS_LOR (bs,cs,ds))
      : CHANGE_BIT_BITS (n,bs,bn,I,ds)
 = case+ single of
   | SINGLE_BIT_BITS_bas {n':int}{bits0:bits} (beqint)  => let
       prval BITS_LOR_CONS {b,c,d:bit}{bs',cs',ds':bits}
                           (bit_lor,bits_lor) = lor_p
       prval (bs'len,cs'len,ds'len)           = bitslor__eq_bitslen (bits_lor)
       prval (cs'len2)                        = bitseqint__bitslen (beqint)
       prval ()                               = bitslen_injective (cs'len, cs'len2)
       prval ()                               = lor_1_assign {b,d} (bit_lor)
       prval ()                               = bit_eq_comm {I,d}()
       prval ()                               = bitslor_0_nochange {n'}{bs',cs',ds'}(bits_lor,beqint)
       prval ()                               = bits_eq_comm {bs',ds'}()
       // CHANGE_BIT_BITS (n'+1,BitsCons (b,bs'),n',d,BitsCons (d,bs'))
       prval chbit                            = CHANGE_BIT_BITS_bas {n'}{b,d}{bs'} (bs'len)
       prval ()                               = bit_eq_refl {d} ()
       prval ()                               = bits_cons_eq {d,d}{bs',ds'} ()
       prval ()                               = bits_eq_refl {bs} ()
     in change_bit_bits_eq {n,0}{d,I}{bs,BitsCons (bs',d),bs,BitsCons (ds',d)}(chbit) end
   | SINGLE_BIT_BITS_ind {n',bn}{cs'}(single') => let
       prval BITS_LOR_CONS {b,c,d:bit}{bs',cs',ds':bits}
                           (bit_lor,bits_lor) = lor_p
       prval ()                               = lor_0_nochange (bit_lor)
       // CHANGE_BIT_BITS (n'+1,BitsCons (bs',?),bn,I,BitsCons (ds',?))
       prval chbit                            = CHANGE_BIT_BITS_ind (singlebitslor__changebit1 (single',bits_lor))
       prval ()                               = bits_eq_refl {ds'} ()
       prval ()                               = bits_cons_eq {b,d}{ds',ds'} ()
       prval ()                               = bit_eq_refl {I} ()
       prval ()                               = bits_eq_refl {bs} ()
     in change_bit_bits_eq {n,bn+1}{I,I}{bs,BitsCons (ds',b),bs,BitsCons (ds',d)}(chbit) end

(*
fn {bs:bits}
  setBitBits {n,bn:nat | bn < n; n < INTBITS} (bits_uint_t (n,bs),uint bn)
  : [cs:bits] (CHANGE_BIT_BITS (n,bs,bn,I,cs) | bits_uint_t (n,cs))
*)
implement {bs:bits} setBitBits {n,bn} (v,bn)
 = let
     prval (biteq | intv) = v
     prval () = beqint_is_nat (biteq)
     val+ (bs_single | sb_v)  = make_single_bit<n,bn> (bn)
     val+ (bs_lor    | lor_v) = bits_uint_lor (v,sb_v)
     prval changebit = singlebitslor__changebit1 (bs_single, bs_lor)
   in (changebit | lor_v) end

prfun bitsland__eq_bitslen {bs,cs,ds:bits} .<bs>. (bsand:BITS_LAND (bs,cs,ds))
                           :[n:int] (BITSLEN (bs,n),BITSLEN (cs,n),BITSLEN (ds,n))
 = case+ bsand of
   | BITS_LAND_NIL  ()          => (BITSLENNIL,BITSLENNIL,BITSLENNIL)
   | BITS_LAND_CONS (band,bs'and) => let
       prval (bs'len,cs'len,ds'len) = bitsland__eq_bitslen (bs'and)
     in (BITSLENCONS (bs'len),BITSLENCONS (cs'len),BITSLENCONS (ds'len)) end

prfun bitsnot__eq_bitslen {bs,cs:bits} .<bs>.(bs_not:BITS_NOT (bs,cs))
                          :[n:int] (BITSLEN (bs,n),BITSLEN (cs,n))
 = case+ bs_not of
   | BITS_NOT_NIL ()             => (BITSLENNIL,BITSLENNIL)
   | BITS_NOT_CONS (bnot,bs'not) => let
       prval (bs'len,cs'len) = bitsnot__eq_bitslen (bs'not)
   in (BITSLENCONS (bs'len),BITSLENCONS (cs'len)) end

prfn land_1_nochange {b,c:bit} (band:BIT_LAND (b,I,c)):[b == c] void
 = case+ band of
   | BIT_LAND_II ()   => bit_eq_refl {I} () // I=I
   | BIT_LAND_IO () =/=> () // O≠I
   | BIT_LAND_OI ()   => bit_eq_refl {O} () // O=O
   | BIT_LAND_OO () =/=> () // O≠I

prfn land_0_assign   {b,c:bit} (band:BIT_LAND (b,O,c)):[O == c] void
 = case+ band of
   | BIT_LAND_II () =/=> () // I≠O
   | BIT_LAND_IO ()   => bit_eq_refl {O} () // O=O
   | BIT_LAND_OI () =/=> () // I≠O
   | BIT_LAND_OO ()   => bit_eq_refl {O} () // O=O

prfun bitsland_not0_nochange {n:int}{bs,cs,ds,es:bits} .<bs>.
      (bs_and_ds:BITS_LAND (bs,ds,es),cs_eq0:BITSEQINT (n,cs,0),cs_not:BITS_NOT (cs,ds))
      :[bs == es] void
 = scase bs of
   | BitsNil ()       => let
       prval BITS_LAND_NIL () = bs_and_ds
     in bits_eq_refl {BitsNil} () end // BitsNil = BitsNil
   | BitsCons (bs',b) => scase es of
       | BitsCons (es',e) => let
           prval BITS_LAND_CONS (b_and_d,bs'_and_ds') = bs_and_ds
           prval BITS_NOT_CONS (c_not,cs'_not)        = cs_not
           prval BEQCONS (cs'_eq0,B0EQ0 ())           = cs_eq0
           prval BIT_NOT0 ()                          = c_not
           prval ()                                   = land_1_nochange (b_and_d)
           prval ()                                   = bitsland_not0_nochange (bs'_and_ds',cs'_eq0,cs'_not)
         in bits_cons_eq {b,e}{bs',es'}() end
       | BitsNil () => case+ bs_and_ds of
                       | BITS_LAND_NIL  ()    =/=> ()
                       | BITS_LAND_CONS (_,_) =/=> ()

prfun notsinglebitsland__changebit0 {n,bn:int}{bs,cs,ds,es:bits} .<bs>.
      (cs_is_single:SINGLE_BIT_BITS (n,bn,cs),cs_not:BITS_NOT (cs,ds),bs_and_ds:BITS_LAND (bs,ds,es))
      :CHANGE_BIT_BITS (n,bs,bn,O,es)
 = case+ cs_is_single of
   | SINGLE_BIT_BITS_bas {n':int}{cs':bits} (cs'_eq_0)  => let
       prval BITS_NOT_CONS {c,d}{cs',ds'} (BIT_NOT1 (),cs'_not)      = cs_not
       prval BITS_LAND_CONS {b,d,e:bit}{bs',ds',es':bits}
                            (b_and_d,bs'_and_ds') = bs_and_ds
       prval [cd'n:int](cs'len,ds'len) = bitsnot__eq_bitslen (cs'_not)
       prval (cs'len') = bitseqint__bitslen (cs'_eq_0)
       prval [bde'n:int](bs'len,ds'len',es'len) = bitsland__eq_bitslen (bs'_and_ds')
       prval ()                                 = bitslen_injective (ds'len, ds'len')
       prval ()                                 = bitslen_injective (cs'len, cs'len')
       prval ()                                 = land_0_assign {b,e} (b_and_d)
       prval ()                                 = bit_eq_comm {O,e}()
       prval ()                                 = bitsland_not0_nochange {n'}{bs',cs',ds',es'}(bs'_and_ds',cs'_eq_0,cs'_not)
       // CHANGE_BIT_BITS (n'+1,BitsCons (bs',b),n',d,BitsCons (bs',e))
       prval chbit                  = CHANGE_BIT_BITS_bas {n'}{b,e}{bs'} (bs'len)
       prval ()                     = bit_eq_refl {e} ()
       prval ()                     = bits_cons_eq {e,e}{bs',es'} ()
       prval ()                     = bits_eq_refl {bs} ()
     in change_bit_bits_eq {n,0}{e,O}{bs,BitsCons (bs',e),bs,BitsCons (es',e)}(chbit) end
   | SINGLE_BIT_BITS_ind {n',bn}{cs'}(single') => let
       prval BITS_NOT_CONS (BIT_NOT0 (),cs'_not)       = cs_not
       prval BITS_LAND_CONS {b,d,e:bit}{bs',ds',es':bits}
                           (b_and_d,bs'_and_ds') = bs_and_ds
       prval ()                                  = land_1_nochange (b_and_d)
       // CHANGE_BIT_BITS (n'+1,BitsCons (bs',?),bn,I,BitsCons (ds',?))
       prval chbit                               = CHANGE_BIT_BITS_ind (notsinglebitsland__changebit0 (single',cs'_not,bs'_and_ds'))
       prval ()                                  = bits_eq_refl {es'} ()
       prval ()                                  = bits_cons_eq {b,e}{es',es'} ()
       prval ()                                  = bit_eq_refl {O} ()
       prval ()                                  = bits_eq_refl {bs} ()
     in change_bit_bits_eq {n,bn+1}{O,O}{bs,BitsCons (es',b),bs,BitsCons (es',e)}(chbit) end

implement {bs} clearBitBits {n,bn} (v,bn)
 = let
     prval (biteq | intv) = v
     prval () = beqint_is_nat (biteq)
     val+ (bs_single | sb_v)    = make_single_bit<n,bn> (bn)
     val+ (bs_not    | notsb_v) = bits_uint_not (sb_v)
     val+ (bs_land   | land_v)  = bits_uint_land (v,notsb_v)
     prval changebit = notsinglebitsland__changebit0 (bs_single,bs_not,bs_land)
   in (changebit | land_v) end

(*
fn {b:bit}{bs:bits}
  changeBitBits {n,bn:nat | bn < n; n < INTBITS} (bits_uint_t (n,bs),uint bn,bit_uint_t b)
  : [bs':bits] (CHANGE_BIT_BITS (n,bs,bn,b,bs') | bits_uint_t (n,bs'))
*)
implement {b}{bs} changeBitBits {n,bn} (v,bn,bint)
 = let
     prval (biteq | bint') = bint
     prval () = beqint_nat2<b> (biteq)
   in if (bint' = 0)
      then let prval () = beq0__b_is_O<b> (biteq)
                 val+ (chgbit | bitint) = clearBitBits (v,bn)
             in (chgbit_bit_eq (chgbit) | bitint) end
      else let prval () = beq1__b_is_I<b> (biteq)
                 val+ (chgbit | bitint) = setBitBits (v,bn)
             in (chgbit_bit_eq (chgbit) | bitint) end
   end

prfun bitsland0_assign {n:int}{bs,cs,ds:bits} .<bs>.
                       (bs_and_cs:BITS_LAND (bs,cs,ds), cs_eq_0:BITSEQINT (n,cs,0))
                       :[cs == ds] void
 = case+ bs_and_cs of
   | BITS_LAND_NIL ()                      => bits_eq_refl {BitsNil}()
   | BITS_LAND_CONS {b,c,d}{bs',cs',ds'} (b_and_c, bs'_and_cs') =>
     case+ cs_eq_0 of
     | BEQCONS (cs'_eq_0,B0EQ0 ()) => let
         prval () = land_0_assign (b_and_c)
         prval () = bitsland0_assign (bs'_and_cs',cs'_eq_0)
       in bits_cons_eq {O,d}{cs',ds'} () end
     | BEQCONS (cs'_eq_0,B1EQ1 ()) =/=> ()
     | BEQNIL ()           =/=> ()

prfun bitseqint_injective {n,m,v,w:int}{bs:bits} .<bs>.
                          (bs_eq_v:BITSEQINT (n,bs,v), bs_eq_w:BITSEQINT (m,bs,w))
                          :[n == m][v == w] void
 = scase bs of
   | BitsNil ()       => let
       prval BEQNIL () = bs_eq_v
       prval BEQNIL () = bs_eq_w
     in end
   | BitsCons (bs',b) =>
     scase b of
     | O () => let
         prval BEQCONS (bs'_eq_v',B0EQ0 ()) = bs_eq_v
         prval BEQCONS (bs'_eq_w',B0EQ0 ()) = bs_eq_w
       in bitseqint_injective (bs'_eq_v',bs'_eq_w') end
     | I () => let
         prval BEQCONS (bs'_eq_v',B1EQ1 ()) = bs_eq_v
         prval BEQCONS (bs'_eq_w',B1EQ1 ()) = bs_eq_w
       in bitseqint_injective (bs'_eq_v',bs'_eq_w') end

prfn bitseq_comm {bs,cs:bits | bs == cs} ():[cs == bs] void
 = let prval EQBITS () = eqbits_make {bs,cs} () in bits_eq_refl {bs} () end

prfn bitseq_bitseqint_assign {n,v:int}{bs,cs:bits | bs == cs}
                             (bs_eq_v:BITSEQINT (n,bs,v)) : BITSEQINT (n,cs,v)
 = let prval EQBITS () = eqbits_make {bs,cs} () in bs_eq_v end

prfn testbits_eq_assign {n:int}{b,c:bit | b == c}{bs:bits}
                        (testbits:TEST_BIT_BITS (bs,n,b)): TEST_BIT_BITS (bs,n,c)
 = let prval EQBIT () = eqbit_make {b,c} () in testbits end

prfn bit_not_O_eq_I ():[~(O == I)] void
 = let
     prval () = bit_not_I_eq_O ()
     prval () = bit_not_eq_comm {I,O}()
   in end

prfn bit_I_neq_O ():[I != O] void = bit_not_I_eq_O ()
prfn bit_O_neq_I ():[O != I] void = bit_not_O_eq_I ()

prfn bit_neq__not_eq {b,c:bit | b != c}():[~(b == c)] void = ()
prfn bit_eq__not_neq {b,c:bit | b == c}():[~(b != c)] void = ()

prfun singlebit_n_gt_0 {n,bn:int}{bs:bits}.<bs>.(bssingle:SINGLE_BIT_BITS (n,bn,bs)):[0 < n] void
 = sif 0 < n then ()
 	 else case+ bssingle of
   | SINGLE_BIT_BITS_bas (bs'eq0) =/=> bitslen_nat (bitseqint__bitslen (bs'eq0))
   | SINGLE_BIT_BITS_ind (bs'single) =/=> singlebit_n_gt_0 (bs'single)

prfun singlebit_bn_lt_n {n,bn:int}{bs:bits} .<bs>. (single:SINGLE_BIT_BITS (n,bn,bs)):[bn < n] void
 = case+ single of
   | SINGLE_BIT_BITS_bas (bs'_eq_0) => singlebit_n_gt_0 (single)
   | SINGLE_BIT_BITS_ind (bs'_is_single) => singlebit_bn_lt_n (bs'_is_single)

prfun singlebit_and_bs_neq0__testbit
      {n,bn,v:int | n < INTBITS; bn < n}
      {bs,cs,ds:bits}
      .<bs>.
      (bs_and_cs    :BITS_LAND (bs,cs,ds),
       cs_is_single :SINGLE_BIT_BITS (n,bn,cs),
       ds_eq_v      :BITSEQINT (n,ds,v))
      : [b:bit | ~(v==0) == (b==I)] TEST_BIT_BITS (bs,bn,b)
 = case+ cs_is_single of
   | SINGLE_BIT_BITS_bas {n':int}{cs':bits} (cs'_eq_0)  => let
       prval BITS_LAND_CONS {b,c,d}{bs',cs',ds'}(b_and_c,bs'_and_cs')
                     = bs_and_cs
       prval ()      = bitsland0_assign (bs'_and_cs',cs'_eq_0)
       prval [bcd'n:int] (bs'_len,cs'_len,ds'_len)
                     = bitsland__eq_bitslen (bs'_and_cs')
       prval cs'_len' = bitseqint__bitslen (cs'_eq_0)
       prval ()      = bitslen_injective (cs'_len, cs'_len')
     in case+ ds_eq_v of
        | BEQNIL   ()          =/=> ()
        | BEQCONS {ds'n}{b0}{ds''}{v',bitv} (ds'_eq_v',B0EQ0 ())   => let
              prval ()       = bitsland0_assign {n'}{bs',cs',ds'}(bs'_and_cs',cs'_eq_0)
              prval ()       = bitseq_comm {cs',ds'}()
            prval ds'_eq_0 = bitseq_bitseqint_assign {n',0}{cs',ds'}(cs'_eq_0)
            prval ()       = bitseqint_injective {n',n',0,v'} (ds'_eq_0,ds'_eq_v')
              prval eqintv'  = eqint_make {v',0} ()
              prval eqintv'  = eqint_make {0,v'+v'} ()
            prval ()       = land_1_nochange {b,O} (b_and_c)
              prval ()       = bits_eq_refl {bs'} ()
              prval ()       = bits_cons_eq {b,O}{bs',bs'} ()
              prval ()       = bits_eq_comm {BitsCons (bs',b), BitsCons (bs',O)} ()
              prval ()       = bit_eq_comm {b,O} ()
              prval EQBIT () = eqbit_make {b,O} ()
              prval ()       = bit_I_neq_O ()
              prval ()       = bit_not_O_eq_I ()
            prval testbits = TEST_BIT_BITS_bas {n'}{b}{bs'} (bs'_len)
          in testbits end
        | BEQCONS {ds'n}{b1}{ds''}{v',bitv} (ds'_eq_v',B1EQ1 ())   => let
            prval ds'_eq_0 = bitseq_bitseqint_assign {n',0}{cs',ds'}(cs'_eq_0)
            prval ()       = bitseqint_injective {n',n',0,v'} (ds'_eq_0,ds'_eq_v')
            prval ()       = land_1_nochange {b,I} (b_and_c)
          in TEST_BIT_BITS_bas (bs'_len) end
     end
   | SINGLE_BIT_BITS_ind {n',bn}{cs'} (cs'_is_single) => let
       prval BITS_LAND_CONS {b,c,d}{bs',cs',ds'} (b_and_c,bs'_and_cs') = bs_and_cs
       prval ()                                   = singlebit_bn_lt_n (cs'_is_single)
     in case+ ds_eq_v of
        | BEQCONS {ds'n}{ds'}{v'} (ds'_eq_v',B0EQ0 ()) => let
            prval testbit' = singlebit_and_bs_neq0__testbit (bs'_and_cs',cs'_is_single,ds'_eq_v')
          in TEST_BIT_BITS_ind (testbit') end
        | BEQCONS {ds'n}{ds''}{v'} (ds'_eq_v',B1EQ1 ()) =/=> let
            prval ()         = land_0_assign (b_and_c)
            prval ()         = bit_eq_comm {O,d} ()
            prval EQBIT ()   = eqbit_make {d,O} ()
            prval ()         = bit_eq_refl {d} ()
          in end
     end

(*
fn {bs:bits}
  testBitBits {n,bn:nat | bn < n}{n < INTBITS} (bits_uint_t (n,bs),uint bn)
  : [b:bit] (TEST_BIT_BITS (bs,bn,b) | bool (b==I))
*)
implement {bs} testBitBits {n,bn} (v,bn)
 = let
     val+  (cs_is_single | cs_v)      = make_single_bit<n,bn> (bn)
     val+  (bs_and_cs    | ds_uint_v) = bits_uint_land (v,cs_v)
     val+  (dseqint      | uint_v)    = ds_uint_v
     prval (bstest)                   = singlebit_and_bs_neq0__testbit (bs_and_cs,cs_is_single,dseqint)
   in (bstest | not (uint_v = i2u(0))) end

(*
prfn bitspermcert_0 {bs:bits}(
    BITS_PERMIT_CERTIFICATE (8,BitPermissions8 (
        Permit,Prohibit, Permit,Prohibit, Permit,Prohibit, Permit,Prohibit,
        Permit,Prohibit, Permit,Prohibit, Permit,Prohibit, Permit,Prohibit),
      bs))
    : [bs == Bits8 (O,O,O,O,O,O,O,O)] void
*)
primplement bitspermcert_0 {bs}(perms)
 = let
     prval BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (
           BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (
           BITPERMCERTS_NIL (),
           BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()),
           BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()) = perms
   in bits_eq_refl {bs}() end

(*
prfn bitspermcert_1 {bs:bits}(
    BITS_PERMIT_CERTIFICATE (8,BitPermissions8 (
        Permit,Prohibit, Permit,Prohibit, Permit,Prohibit, Permit,Prohibit,
        Permit,Prohibit, Permit,Prohibit, Permit,Prohibit, Prohibit,Permit),
      bs))
    : [bs == Bits8 (O,O,O,O,O,O,O,I)] void
*)
primplement bitspermcert_1 {bs}(perms)
 = let
     prval BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (
           BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (
           BITPERMCERTS_NIL (),
           BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()),
           BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_1 ())
            = perms
   in bits_eq_refl {bs}() end

(*
prfn bitspermcert_2 {bs:bits}(
    BITS_PERMIT_CERTIFICATE (8,BitPermissions8 (
        Permit,Prohibit, Permit,Prohibit, Permit,Prohibit, Permit,Prohibit,
        Permit,Prohibit, Permit,Prohibit, Prohibit,Permit, Permit,Prohibit),
      bs))
    : [bs == Bits8 (O,O,O,O,O,O,I,O)] void
*)
primplement bitspermcert_2 {bs}(perms)
 = let
     prval BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (
           BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (
           BITPERMCERTS_NIL (),
           BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()),
           BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_1 ()),BITPERMCERT_0 ()) = perms
   in bits_eq_refl {bs}() end

(*
prfn bitspermcert_128 {bs:bits}(
    BITS_PERMIT_CERTIFICATE (8,BitPermissions8 (
        Prohibit,Permit, Permit,Prohibit, Permit,Prohibit, Permit,Prohibit,
        Permit,Prohibit, Permit,Prohibit, Permit,Prohibit, Permit,Prohibit),
      bs))
    : [bs == Bits8 (I,O,O,O,O,O,O,O)] void
*)
primplement bitspermcert_128 {bs}(perms)
 = let
     prval BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (
     			 BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (
           BITPERMCERTS_NIL (),
     			 BITPERMCERT_1 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()),
           BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()),BITPERMCERT_0 ()) = perms
   in bits_eq_refl {bs}() end

(*
prfn bitspermcert_255 {bs:bits}(
    BITS_PERMIT_CERTIFICATE (8,BitPermissions8 (
        Prohibit,Permit, Prohibit,Permit, Prohibit,Permit, Prohibit,Permit,
        Prohibit,Permit, Prohibit,Permit, Prohibit,Permit, Prohibit,Permit),
      bs))
    : [bs == Bits8 (I,I,I,I,I,I,I,I)] void
*)
primplement bitspermcert_255 {bs}(perms)
 = let
     prval BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (
     			 BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (
           BITPERMCERTS_NIL (),
           BITPERMCERT_1 ()),BITPERMCERT_1 ()),BITPERMCERT_1 ()),BITPERMCERT_1 ()),
           BITPERMCERT_1 ()),BITPERMCERT_1 ()),BITPERMCERT_1 ()),BITPERMCERT_1 ()) = perms
   in bits_eq_refl {bs}() end

(*
prfn bitspermcert_all {bs:bits}(BITSLEN (bs,8)):
    BITS_PERMIT_CERTIFICATE (8,BitPermissions8 (
        Permit,Permit, Permit,Permit, Permit,Permit, Permit,Permit,
        Permit,Permit, Permit,Permit, Permit,Permit, Permit,Permit),
      bs)
*)

prfn bperm_all {b:bit} ():
       BIT_PERMIT_CERTIFICATE (BitPermission (Permit,Permit),b)
 = scase b of
   | I () => BITPERMCERT_1 ()
   | O () => BITPERMCERT_0 ()

prfun bitslen0__nil {bs:bits}.<bs>.(bslen:BITSLEN (bs,0)): [bs == BitsNil] void
 = case+ bslen of
   | BITSLENNIL ()        =>   bits_eq_refl {bs}()
   | BITSLENCONS (bs'len) =/=> bitslen_nat (bs'len)

(*prfn bitspermcert_all {bs:bits}(BITSLEN (bs,8)):
    BITS_PERMIT_CERTIFICATE (8,BitPermissions8 (
        Permit,Permit, Permit,Permit, Permit,Permit, Permit,Permit,
        Permit,Permit, Permit,Permit, Permit,Permit, Permit,Permit),
      bs)*)
primplement bitspermcert_all {bs8}(bs8len)
 = let
     prval BITSLENCONS {n7}{b0}{bs7}(bs7len) = bs8len
     prval BITSLENCONS {n6}{b1}{bs6}(bs6len) = bs7len
     prval BITSLENCONS {n5}{b2}{bs5}(bs5len) = bs6len
     prval BITSLENCONS {n4}{b3}{bs4}(bs4len) = bs5len
     prval BITSLENCONS {n3}{b4}{bs3}(bs3len) = bs4len
     prval BITSLENCONS {n2}{b5}{bs2}(bs2len) = bs3len
     prval BITSLENCONS {n1}{b6}{bs1}(bs1len) = bs2len
     prval BITSLENCONS {n0}{b7}{bs0}(bs0len) = bs1len
     prval () = bitslen0__nil {bs0}(bs0len)
     prval EQBITS () = eqbits_make {bs0,BitsNil}()
   in BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (
   	  BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (BITPERMCERTS_CONS (
   	  BITPERMCERTS_NIL (),
   	  bperm_all {b7}()),bperm_all {b6}()),bperm_all {b5}()),bperm_all {b4}()),
   	  bperm_all {b3}()),bperm_all {b2}()),bperm_all {b1}()),bperm_all {b0}()) end

(*
prfn bitspermcert_inhaditat {any_prop:prop}{n:int}{bs:bits}{ps:bit_permissions}
    (BITS_PERMIT_CERTIFICATE (n,
       BitPermsCons(BitPermission (Prohibit,Prohibit), ps),
       bs)): any_prop
*)

primplement bitspermcert_inhaditat {any_prop}{n}{bs}{ps}(perms)
 = let
     prval BITPERMCERTS_CONS (perms',perm) = perms
   in case+ perm of
      | BITPERMCERT_0 () =/=> ()
      | BITPERMCERT_1 () =/=> ()
   end

(*
prfun bitspermcerts_prohibit {any_prop:prop}{n:int}{bs:bits}{ps,qs,rs:bit_permissions}
    (BIT_PERMS_ADD (ps,BitPermsCons (BitPermission (Prohibit,Prohibit),qs),rs),
     BITS_PERMIT_CERTIFICATE (n,rs,bs))
    : any_prop
*)
primplement bitspermcerts_prohibit {any_prop}{n}{bs}{ps,qs',rs}(ps_qs_add,perms)
 = case+ ps_qs_add of
   | BIT_PERMS_ADD_NIL () => bitspermcert_inhaditat (perms)
   | BIT_PERMS_ADD_CONS {p}{ps',qs,rs'}(ps'_qs_add) => let
       prval BITPERMCERTS_CONS {n'}{r2}{rs'2}{b}{bs'} (perms',perm) = perms
     in bitspermcerts_prohibit {any_prop}{n'}{bs'}{ps',qs',rs'}(ps'_qs_add,perms') end

(*
fn {n:int}{bs,cs:bits} bits_uint_lor (n:bits_uint_t (n,bs),m:bits_uint_t (n,cs)):
   [ds:bits] (BITS_LOR (bs,cs,ds) | bits_uint_t (n,ds))
*)
implement {n}{bs,cs} bits_uint_lor (v,w)
 = let
     extern prfun bitseqint_total {n,v:int} ():[bs:bits] BITSEQINT (n,bs,v)
     val+ (bs_eq_v | uint_v) = v
     val+ (cs_eq_w | uint_w) = w
     val+ [r:int] uint_r = g1ofg0_uint (uint_v lor uint_w)
     prval [ds] ds_eq_r = bitseqint_total {n,r}()
     prval bs_lor_cs = $UN.proof_assert {BITS_LOR (bs,cs,ds)}()
   in (bs_lor_cs | (ds_eq_r | uint_r)) end

(*
fn {n:int}{bs,cs:bits} bits_uint_land (n:bits_uint_t (n,bs),m:bits_uint_t (n,cs)):
   [ds:bits] (BITS_LAND (bs,cs,ds) | bits_uint_t (n,ds))
*)
implement {n}{bs,cs} bits_uint_land (v,w)
 = let
     extern prfun bitseqint_total {n,v:int} ():[bs:bits] BITSEQINT (n,bs,v)
     val+ (bs_eq_v | uint_v) = v
     val+ (cs_eq_w | uint_w) = w
     val+ [r:int] uint_r = g1ofg0_uint (uint_v land uint_w)
     prval [ds] ds_eq_r = bitseqint_total {n,r}()
     prval bs_lor_cs = $UN.proof_assert {BITS_LAND (bs,cs,ds)}()
   in (bs_lor_cs | (ds_eq_r | uint_r)) end

(*
fn {n,bn:int} make_single_bit (bn:uint bn):
  [bs:bits] (SINGLE_BIT_BITS (n,bn,bs) | bits_uint_t (n,bs))
*)
implement {n,bn} make_single_bit (uint_v)
 = let
     extern prfun bitseqint_total {n,v:int} ():[bs:bits] BITSEQINT (n,bs,v)
     val+ [r:int] uint_r = g1ofg0_uint (g0int2uint (1) << g1uint2int (uint_v))
     prval [cs] cs_eq_r = bitseqint_total {n,r}()
     prval cs_single = $UN.proof_assert {SINGLE_BIT_BITS (n,bn,cs)}()
   in (cs_single | (cs_eq_r | uint_r)) end

(*
fn {n:int}{bs:bits} bits_uint_not (n:bits_uint_t (n,bs)):
   [cs:bits] (BITS_NOT (bs,cs) | bits_uint_t (n,cs))
*)
implement {n}{bs} bits_uint_not (v)
 = let
     extern prfun bitseqint_total {n,v:int} ():[bs:bits] BITSEQINT (n,bs,v)
     val+ (bs_eq_v | uint_v) = v
     val+ [r:int] uint_r = g1ofg0_uint (~uint_v)
     prval [cs] cs_eq_r = bitseqint_total {n,r}()
     prval bs_lnot = $UN.proof_assert {BITS_NOT (bs,cs)}()
   in (bs_lnot | (cs_eq_r | uint_r)) end


Updating: very minorly fixing

Updating: very minorly fixing

(*
** Factorials
*)

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

#define ATS_DYNLOADFLAG 0

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

#define
ATS_EXTERN_PREFIX "fact_client_"
#define
ATS_STATIC_PREFIX "_fact_client_"

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

%{^
%%
-module(fact_client_dats).
%%
-export([main0_erl/0]).
%%
-compile(nowarn_unused_vars).
-compile(nowarn_unused_function).
%%
-export([ats2erlpre_cloref1_app/2]).
-export([ats2erlpre_cloref2_app/3]).
-export([libats2erl_session_chque_server/0]).
-export([libats2erl_session_chanpos_server/2]).
-export([libats2erl_session_channeg_server/2]).
%%
-include("./../../libatscc2erl_all.hrl").
-include("./../../Session/mylibats2erl_all.hrl").
%%
%} // end of [%{]

(* ****** ****** *)
//
#include
"./../../staloadall.hats"
//
staload "./../SATS/basis.sats"
//
(* ****** ****** *)

staload "./fact_server.dats"

(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

macdef
SERVICE_NODE = $extval(atom, "'fact_server@xats.bu.edu'")

(* ****** ****** *)
//
extern
fun
fact_client(n: int): int
//
implement
fact_client(n) = let
//
val chn =
  chansrvc_request($UN.cast{service_fact}($tup(SERVICE_FACT,SERVICE_NODE)))
//
val () = channel_send(chn, n)
val result = channel_recv(chn)
val ((*closed*)) = channeg_nil_close(chn)
//
in
  result
end // end of [fact_client]
//
(* ****** ****** *)

extern
fun
main0_erl
(
// argumentless
) : void = "mac#"
//
implement
main0_erl () =
{
//
val N = 10
val ((*void*)) = println! ("fact(", N, ") = ", fact_client(N))
val N = 12
val ((*void*)) = println! ("fact(", N, ") = ", fact_client(N))
val N = 100
val ((*void*)) = println! ("fact(", N, ") = ", fact_client(N))
//
} (* end of [main0_erl] *)

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

(* end of [fact_client.dats] *)

(*
** Factorials
*)

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

#define ATS_DYNLOADFLAG 0

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

#define
ATS_EXTERN_PREFIX "fact_client_"
#define
ATS_STATIC_PREFIX "_fact_client_"

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

%{^
%%
-module(fact_client_dats).
%%
-export([main0_erl/0]).
%%
-compile(nowarn_unused_vars).
-compile(nowarn_unused_function).
%%
-export([ats2erlpre_cloref1_app/2]).
-export([ats2erlpre_cloref2_app/3]).
-export([libats2erl_session_chque_server/0]).
-export([libats2erl_session_chanpos_server/2]).
-export([libats2erl_session_channeg_server/2]).
%%
-include("./../../libatscc2erl_all.hrl").
-include("./../../Session/mylibats2erl_all.hrl").
%%
%} // end of [%{]

(* ****** ****** *)
//
#include
"./../../staloadall.hats"
//
staload "./../SATS/basis.sats"
//
(* ****** ****** *)

staload "./fact_server.dats"

(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

macdef
SERVICE_NODE = $extval(atom, "'fact_server@xats.bu.edu'")

(* ****** ****** *)
//
extern
fun
fact_client(n: int): int
//
implement
fact_client(n) = let
//
val chn =
  chansrvc_request($UN.cast{service_fact}($tup(SERVICE_NODE,SERVICE_FACT)))
//
val () = channel_send(chn, n)
val result = channel_recv(chn)
val ((*closed*)) = channeg_nil_close(chn)
//
in
  result
end // end of [fact_client]
//
(* ****** ****** *)

extern
fun
main0_erl
(
// argumentless
) : void = "mac#"
//
implement
main0_erl () =
{
//
val N = 10
val ((*void*)) = println! ("fact(", N, ") = ", fact_client(N))
val N = 12
val ((*void*)) = println! ("fact(", N, ") = ", fact_client(N))
val N = 100
val ((*void*)) = println! ("fact(", N, ") = ", fact_client(N))
//
} (* end of [main0_erl] *)

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

(* end of [fact_client.dats] *)


Updating: very very minorly

Updating: very very minorly

(*
//
// Animating Quicksort
//
*)
(* ****** ****** *)
//
// Authors:
// William Blair and Hongwei Xi
// Start time: October, 2013
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
staload "libats/ML/SATS/basis.sats"
staload "libats/ML/SATS/list0.sats"
staload "libats/ML/SATS/array0.sats"
//
staload _ = "libats/ML/DATS/list0.dats"
staload _ = "libats/ML/DATS/array0.dats"
//
(* ****** ****** *)
//
#define
HTML_targetloc
"$PATSCONTRIB/contrib/HTML-emscripten"
//
staload "{$HTML}/SATS/document.sats"
staload "{$HTML}/canvas-2d/SATS/canvas2d.sats"
//
(* ****** ****** *)

(*
** Generate a number in [0, 1)
*)
extern
fun
Math_random
(
(*void*)
) : double = "ext#JS_Math_random"
// end of [Math_random]

(* ****** ****** *)
//
#define
HX_MYTESTING_targetloc
"\
$PATSHOME\
/contrib/atscntrb\
/atscntrb-hx-mytesting"
//
staload
"{$HX_MYTESTING}/SATS/randgen.sats"
staload _ =
"{$HX_MYTESTING}/DATS/randgen.dats"
//
(* ****** ****** *)

extern
fun{a:t@ype}
array0_swap
  (A: array0 (a), i: size_t, j: size_t): void
// end of [array0_swap]

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

typedef range_t = @(size_t, size_t)

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

extern
fun{
a:t@ype
} qsort (
  A: array0 (a), st: size_t, len: size_t
) : void // end of [qsort]

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

extern
fun{a:t@ype}
qsort_partition
  (A: array0 (a), st: size_t, len: size_t): size_t
// end of [qsort_partition]

extern
fun{a:t@ype}
qsort_partition_render
  (A: array0 (a), partition: range_t, pivot: size_t): void
// end of [qsort_partition_render]

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

implement
{a}(*tmp*)
qsort (A, st, len) =
(
if len >= 2 then let
  val len_f = qsort_partition<a> (A, st, len)
  val ((*void*)) = qsort<a> (A, st, len_f)
  val len_r = len - len_f
  val ((*void*)) = qsort<a> (A, succ(st+len_f), pred(len_r))
in
  // nothing
end else () // end of [if]
)

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

#define MYMAX 165

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

implement
gcompare_val_val<int>
  (x1, x2) = g0int_compare_int (x1, x2)
// end of [gcompare_val]

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

implement{
} randint{n}(n) =
(
  $UN.cast{natLt(n)} (n * Math_random ())
)

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

implement{a}
qsort_partition
  (A, st, len) = let
//
val last = pred(st+len)
//
// Pick a pivot uniformly at random
//
val n = g1ofg0(g0u2i(len))
val () = assertloc (n > 0)
val offset = i2sz(randint(n))
val pivot = A[st + offset]
val () = array0_swap (A, st + offset, last)
//
val () = qsort_partition_render<a> (A, @(st, len), last)
//
fun loop
(
  k1: size_t, k2: size_t
) : size_t =
  if k2 < last then let
    val sgn = gcompare_val_val<a> (pivot, A[k2])
  in
    if sgn <= 0
      then loop (k1, succ(k2))
      else (array0_swap(A, k1, k2); loop (succ(k1), succ(k2)))
    // end of [if]
  end else k1 // end of [loop]
//
val k1 = loop (st, st)
val () = array0_swap (A, k1, last)
//
in
  (k1 - st)
end // end of [qort_partition]

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

extern
fun intqsort (A: array0(int)): void

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

typedef swap_t = @(size_t, size_t)

datatype
snapshot =
  | Normal of (array0(int))
  | SelectPivot of (array0(int), range_t, size_t)
  | Swap of (array0(int), range_t, size_t, swap_t)
// end of [snapshot]

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

extern
fun
snapshot_pop (): snapshot
extern
fun snapshot_push (snap: snapshot): void
extern
fun snapshot_reverse (): void
extern
fun snapshot_hasmore (): bool

local
//
val theSnapshots =
  ref<list0(snapshot)> (list0_nil)
val theSnapshots_hasmore = ref<bool> (true)
//
in (* in of [local] *)

implement
snapshot_pop () = x where
{
  val-cons0(x, xs) = !theSnapshots
  val () = (
    case+ xs of
    | cons0 _ => !theSnapshots := xs
    | nil0 () => !theSnapshots_hasmore := false
  ) : void (* end of [val] *)
}

implement
snapshot_push (snap) = let
in
  !theSnapshots := list0_cons{snapshot} (snap, !theSnapshots)
end // end of [snapshot_push]

implement
snapshot_reverse () = !theSnapshots := list0_reverse (!theSnapshots)

implement
snapshot_hasmore () = !theSnapshots_hasmore

end // end of [local]

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

extern
fun thePivot_get (): size_t
and thePivot_set (size_t): void
extern
fun thePartition_get (): range_t
and thePartition_set (range_t): void
extern
fun theNextRender_get (): int
and theNextRender_set (int): void
and theNextRender_incby (int): void

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

local

val
thePivot = ref<size_t> (i2sz(0))
and
thePartition = ref<range_t> @(i2sz(0), i2sz(0))

val
theNextRender = ref<int> (0)

in (* in of [local] *)

implement
thePartition_get () = !thePartition
implement
thePartition_set (x) = !thePartition := x

implement
thePivot_get () = !thePivot
implement
thePivot_set (x) = !thePivot := x

implement
theNextRender_get () = !theNextRender
implement
theNextRender_incby (x) = !theNextRender := !theNextRender + x

end // end of [local]

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

implement
qsort_partition_render<int>
  (A, part, p) = let
  val A'   = array0_copy(A)
  val snap = SelectPivot (A', part, p)
  val ()   = thePartition_set (part)
  val ()   = thePivot_set (p)
in
  snapshot_push (snap)
end

implement
intqsort (A) = let
//
implement
array0_swap<int>
  (A, i, j) =
{
val () = let
  val A = array0_copy(A)
  val part = thePartition_get ()
  val pivot = thePivot_get ()
in
  snapshot_push (Swap(A, part, pivot, @(i,j)))
end // end of [val]
//
val tmp = A[i]
val () = A[i] := A[j]
val () = A[j] := tmp
//
}
//
in
  qsort<int> (A, i2sz(0), A.size())
end // end of [intqsort]

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

extern
fun
draw_array0
  {l:agz} (
  cnv: !canvas2d(l), A: array0(int), W: int, H: int, _: range_t, _: int
) : void // end of [draw_array0]

local

val dt = 100

in (* in of [local] *)

implement
draw_array0{l}
(
  cnv, A, W, H, range, p
) = let
//
val n = A.size()
val asz = A.size()
val sx = g0i2f(W) / $UN.cast{double}(asz)
val sy = g0i2f(H) / $UN.cast{double}(MYMAX)
val (pf | ()) = canvas2d_save (cnv)
val () = canvas2d_scale (cnv, sx, sy)
//
fun loop
(
  cnv: !canvas2d l, i: size_t
) : void =
(
  if i < n then let
    val v = A[i]
    val xul = g0uint2int(i)
    val yul = MYMAX - v
    val color = let
      val normal = "rgb(200, 200, 200)"
    in
      case+ p of
      | _ when p = ~1 => normal
      | _  =>> if p = g0uint2int(i) then "rgb(255, 0, 0)" else normal
    end : string // end of [val]
  in
    canvas2d_set_fillStyle_string (cnv, color);
    canvas2d_fillRect (cnv, 1.0 * xul, 1.0 * yul, 1.0, 1.0 * v);
    loop (cnv, succ(i))
  end
) (* end of [loop] *)
//
val () = loop (cnv, i2sz(0))
val part_start = g0uint2int(range.0) and part_len = g0uint2int(range.1)
val () = // draw a blue line to indicate the pivot
if p > ~1 then let
   val v  = A[$UN.cast{size_t}(p)]
   val (pf' | ()) = canvas2d_save (cnv)
in
   canvas2d_beginPath (cnv);
   canvas2d_moveTo (cnv, 1.0 * part_start, 1.0 * (MYMAX - v));
   canvas2d_lineTo (cnv, 1.0 * (part_start + part_len), 1.0 * (MYMAX - v));
   canvas2d_set_lineWidth (cnv, 0.25);
   canvas2d_set_strokeStyle_string (cnv, "#0000FF");
   canvas2d_stroke (cnv);
   canvas2d_closePath (cnv);
   canvas2d_restore (pf' | cnv)
end // end of [if] // end of [val]
//
val () = canvas2d_set_fillStyle_string (cnv, "rgba(0, 0, 0, 0.1)")
val () = canvas2d_fillRect (cnv, 1.0 * part_start, 0.0, 1.0 * part_len, 1.0 * MYMAX)
//
in
  canvas2d_restore (pf | cnv)
end (* end of [draw_array0] *)

(* ****** ****** *)
//
extern
fun canvas2d_set_size_int
(
  id: string
, width: int(*px*), height: int(*px*)
) : void = "ext#JS_canvas2d_set_size_int"
//
extern
fun window_requestAnimationFrame
  (f: (int)-> void): void = "ext#JS_window_requestAnimationFrame"
//
(* ****** ****** *)

extern
fun
start_animation (): void
implement
start_animation () =
window_requestAnimationFrame
(
fix step (timestamp:int): void =>
(
  if theNextRender_get() < timestamp then let
    val shot = snapshot_pop ()
    val () = theNextRender_incby (dt)
    // render the shot
    val cnv = canvas2d_make ("QuicksortAnim")
    val ((*void*)) = assertloc (ptrcast(cnv) > 0)
    // Get the latest dimensions of the viewport
    val W = document_get_documentElement_clientWidth()
    val H = document_get_documentElement_clientHeight()
    // Resize our canvas
    val () = canvas2d_set_size_int ("QuicksortAnim", W, H)
    val Wf = g0i2f(W) and Hf = g0i2f(H)
    val (
    ) = canvas2d_clearRect (cnv, 0.0, 0.0, Wf, Hf)
    val () = canvas2d_set_fillStyle_string (cnv, "#FFFFFF")
    val () = canvas2d_fillRect (cnv, 0.0, 0.0, Wf, Hf)
  in (
    case+ shot of
    | Normal (A) => let
        val range = (i2sz(0), i2sz(0))
      in
        draw_array0 (cnv, A, W, H, range, ~1); canvas2d_free (cnv);
      end
    | SelectPivot (A, range, p) => begin
        draw_array0 (cnv, A, W, H, range, g0uint2int(p)); canvas2d_free (cnv)
      end
    | Swap (A, range, p , _) => begin
        draw_array0 (cnv, A, W, H, range, g0uint2int(p));  canvas2d_free (cnv);
      end
  ) end ; if snapshot_hasmore () then window_requestAnimationFrame (step) ;
)
) // end of [window_requestAnimationFrame]

end // end of [local]

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

(*
staload TIME = "libc/SATS/time.sats"
staload STDLIB = "libc/SATS/stdlib.sats"
*)

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

implement
main0 () = let
//
val N = 150
val N = g1ofg0_int (N)
val () = assertloc (N > 0)
//
(*
val () =
$STDLIB.srand48 ($UN.cast{lint}($TIME.time_get()))
*)
//
(*
** Generate a random permutation of the array [1,2,...,N]
*)
//
val A =
  arrayptr_make_intrange (1, N+1)
val p = ptrcast (A)
prval pf = arrayptr_takeout{int} (A)
implement{}
array_permute$randint{n}(n) = g1i2u(randint(g1u2i(n)))
//
val N = i2sz(N)
//
val () = array_permute (!p, N)
//
prval () = arrayptr_addback (pf | A)
//
val A = arrayptr_refize (A)
val A = array0_make_arrayref (A, N)
//
val out = stdout_ref
//
val () = snapshot_push (Normal(A)) where { val A = array0_copy(A) }
//
val () = intqsort (A)
//
val () = snapshot_push (Normal(A)) where { val A = array0_copy (A) }
//
val () = snapshot_reverse ()
//
in
  start_animation ()
end // end of [main0]

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

(* end of [quicksort_anim.dats] *)

(*
//
// Animating Quicksort
//
*)
(* ****** ****** *)
//
// Authors:
// William Blair and Hongwei Xi
// Start time: October, 2013
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
staload "libats/ML/SATS/basis.sats"
staload "libats/ML/SATS/list0.sats"
staload "libats/ML/SATS/array0.sats"
//
staload _ = "libats/ML/DATS/list0.dats"
staload _ = "libats/ML/DATS/array0.dats"
//
(* ****** ****** *)
//
#define
HTML_targetloc
"$PATSCONTRIB/contrib/HTML-emscripten"
//
staload "{$HTML}/SATS/document.sats"
staload "{$HTML}/canvas-2d/SATS/canvas2d.sats"
//
(* ****** ****** *)

(*
** Generate a number in [0, 1)
*)
extern
fun Math_random
  ((*void*)): double = "ext#JS_Math_random"
// end of [Math_random]

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

staload "{$HX_MYTESTING}/SATS/randgen.sats"
staload _ = "{$HX_MYTESTING}/DATS/randgen.dats"

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

extern
fun{a:t@ype}
array0_swap
  (A: array0 (a), i: size_t, j: size_t): void
// end of [array0_swap]

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

typedef range_t = @(size_t, size_t)

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

extern
fun{
a:t@ype
} qsort (
  A: array0 (a), st: size_t, len: size_t
) : void // end of [qsort]

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

extern
fun{a:t@ype}
qsort_partition
  (A: array0 (a), st: size_t, len: size_t): size_t
// end of [qsort_partition]

extern
fun{a:t@ype}
qsort_partition_render
  (A: array0 (a), partition: range_t, pivot: size_t): void
// end of [qsort_partition_render]

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

implement
{a}(*tmp*)
qsort (A, st, len) =
(
if len >= 2 then let
  val len_f = qsort_partition<a> (A, st, len)
  val ((*void*)) = qsort<a> (A, st, len_f)
  val len_r = len - len_f
  val ((*void*)) = qsort<a> (A, succ(st+len_f), pred(len_r))
in
  // nothing
end else () // end of [if]
)

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

#define MYMAX 165

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

implement
gcompare_val_val<int>
  (x1, x2) = g0int_compare_int (x1, x2)
// end of [gcompare_val]

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

implement{
} randint{n}(n) =
(
  $UN.cast{natLt(n)} (n * Math_random ())
)

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

implement{a}
qsort_partition
  (A, st, len) = let
//
val last = pred(st+len)
//
// Pick a pivot uniformly at random
//
val n = g1ofg0(g0u2i(len))
val () = assertloc (n > 0)
val offset = i2sz(randint(n))
val pivot = A[st + offset]
val () = array0_swap (A, st + offset, last)
//
val () = qsort_partition_render<a> (A, @(st, len), last)
//
fun loop
(
  k1: size_t, k2: size_t
) : size_t =
  if k2 < last then let
    val sgn = gcompare_val_val<a> (pivot, A[k2])
  in
    if sgn <= 0
      then loop (k1, succ(k2))
      else (array0_swap(A, k1, k2); loop (succ(k1), succ(k2)))
    // end of [if]
  end else k1 // end of [loop]
//
val k1 = loop (st, st)
val () = array0_swap (A, k1, last)
//
in
  (k1 - st)
end // end of [qort_partition]

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

extern
fun intqsort (A: array0(int)): void

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

typedef swap_t = @(size_t, size_t)

datatype
snapshot =
  | Normal of (array0(int))
  | SelectPivot of (array0(int), range_t, size_t)
  | Swap of (array0(int), range_t, size_t, swap_t)
// end of [snapshot]

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

extern
fun
snapshot_pop (): snapshot
extern
fun snapshot_push (snap: snapshot): void
extern
fun snapshot_reverse (): void
extern
fun snapshot_hasmore (): bool

local
//
val theSnapshots =
  ref<list0(snapshot)> (list0_nil)
val theSnapshots_hasmore = ref<bool> (true)
//
in (* in of [local] *)

implement
snapshot_pop () = x where
{
  val-cons0(x, xs) = !theSnapshots
  val () = (
    case+ xs of
    | cons0 _ => !theSnapshots := xs
    | nil0 () => !theSnapshots_hasmore := false
  ) : void (* end of [val] *)
}

implement
snapshot_push (snap) = let
in
  !theSnapshots := list0_cons{snapshot} (snap, !theSnapshots)
end // end of [snapshot_push]

implement
snapshot_reverse () = !theSnapshots := list0_reverse (!theSnapshots)

implement
snapshot_hasmore () = !theSnapshots_hasmore

end // end of [local]

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

extern
fun thePivot_get (): size_t
and thePivot_set (size_t): void
extern
fun thePartition_get (): range_t
and thePartition_set (range_t): void
extern
fun theNextRender_get (): int
and theNextRender_set (int): void
and theNextRender_incby (int): void

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

local

val
thePivot = ref<size_t> (i2sz(0))
and
thePartition = ref<range_t> @(i2sz(0), i2sz(0))

val
theNextRender = ref<int> (0)

in (* in of [local] *)

implement
thePartition_get () = !thePartition
implement
thePartition_set (x) = !thePartition := x

implement
thePivot_get () = !thePivot
implement
thePivot_set (x) = !thePivot := x

implement
theNextRender_get () = !theNextRender
implement
theNextRender_incby (x) = !theNextRender := !theNextRender + x

end // end of [local]

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

implement
qsort_partition_render<int>
  (A, part, p) = let
  val A'   = array0_copy(A)
  val snap = SelectPivot (A', part, p)
  val ()   = thePartition_set (part)
  val ()   = thePivot_set (p)
in
  snapshot_push (snap)
end

implement
intqsort (A) = let
//
implement
array0_swap<int>
  (A, i, j) =
{
val () = let
  val A = array0_copy(A)
  val part = thePartition_get ()
  val pivot = thePivot_get ()
in
  snapshot_push (Swap(A, part, pivot, @(i,j)))
end // end of [val]
//
val tmp = A[i]
val () = A[i] := A[j]
val () = A[j] := tmp
//
}
//
in
  qsort<int> (A, i2sz(0), A.size())
end // end of [intqsort]

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

extern
fun
draw_array0
  {l:agz} (
  cnv: !canvas2d(l), A: array0(int), W: int, H: int, _: range_t, _: int
) : void // end of [draw_array0]

local

val dt = 100

in (* in of [local] *)

implement
draw_array0{l}
(
  cnv, A, W, H, range, p
) = let
//
val n = A.size()
val asz = A.size()
val sx = g0i2f(W) / $UN.cast{double}(asz)
val sy = g0i2f(H) / $UN.cast{double}(MYMAX)
val (pf | ()) = canvas2d_save (cnv)
val () = canvas2d_scale (cnv, sx, sy)
//
fun loop
(
  cnv: !canvas2d l, i: size_t
) : void =
(
  if i < n then let
    val v = A[i]
    val xul = g0uint2int(i)
    val yul = MYMAX - v
    val color = let
      val normal = "rgb(200, 200, 200)"
    in
      case+ p of
      | _ when p = ~1 => normal
      | _  =>> if p = g0uint2int(i) then "rgb(255, 0, 0)" else normal
    end : string // end of [val]
  in
    canvas2d_set_fillStyle_string (cnv, color);
    canvas2d_fillRect (cnv, 1.0 * xul, 1.0 * yul, 1.0, 1.0 * v);
    loop (cnv, succ(i))
  end
) (* end of [loop] *)
//
val () = loop (cnv, i2sz(0))
val part_start = g0uint2int(range.0) and part_len = g0uint2int(range.1)
val () = // draw a blue line to indicate the pivot
if p > ~1 then let
   val v  = A[$UN.cast{size_t}(p)]
   val (pf' | ()) = canvas2d_save (cnv)
in
   canvas2d_beginPath (cnv);
   canvas2d_moveTo (cnv, 1.0 * part_start, 1.0 * (MYMAX - v));
   canvas2d_lineTo (cnv, 1.0 * (part_start + part_len), 1.0 * (MYMAX - v));
   canvas2d_set_lineWidth (cnv, 0.25);
   canvas2d_set_strokeStyle_string (cnv, "#0000FF");
   canvas2d_stroke (cnv);
   canvas2d_closePath (cnv);
   canvas2d_restore (pf' | cnv)
end // end of [if] // end of [val]
//
val () = canvas2d_set_fillStyle_string (cnv, "rgba(0, 0, 0, 0.1)")
val () = canvas2d_fillRect (cnv, 1.0 * part_start, 0.0, 1.0 * part_len, 1.0 * MYMAX)
//
in
  canvas2d_restore (pf | cnv)
end (* end of [draw_array0] *)

(* ****** ****** *)
//
extern
fun canvas2d_set_size_int
(
  id: string
, width: int(*px*), height: int(*px*)
) : void = "ext#JS_canvas2d_set_size_int"
//
extern
fun window_requestAnimationFrame
  (f: (int)-> void): void = "ext#JS_window_requestAnimationFrame"
//
(* ****** ****** *)

extern
fun
start_animation (): void
implement
start_animation () =
window_requestAnimationFrame
(
fix step (timestamp:int): void =>
(
  if theNextRender_get() < timestamp then let
    val shot = snapshot_pop ()
    val () = theNextRender_incby (dt)
    // render the shot
    val cnv = canvas2d_make ("QuicksortAnim")
    val ((*void*)) = assertloc (ptrcast(cnv) > 0)
    // Get the latest dimensions of the viewport
    val W = document_get_documentElement_clientWidth()
    val H = document_get_documentElement_clientHeight()
    // Resize our canvas
    val () = canvas2d_set_size_int ("QuicksortAnim", W, H)
    val Wf = g0i2f(W) and Hf = g0i2f(H)
    val (
    ) = canvas2d_clearRect (cnv, 0.0, 0.0, Wf, Hf)
    val () = canvas2d_set_fillStyle_string (cnv, "#FFFFFF")
    val () = canvas2d_fillRect (cnv, 0.0, 0.0, Wf, Hf)
  in (
    case+ shot of
    | Normal (A) => let
        val range = (i2sz(0), i2sz(0))
      in
        draw_array0 (cnv, A, W, H, range, ~1); canvas2d_free (cnv);
      end
    | SelectPivot (A, range, p) => begin
        draw_array0 (cnv, A, W, H, range, g0uint2int(p)); canvas2d_free (cnv)
      end
    | Swap (A, range, p , _) => begin
        draw_array0 (cnv, A, W, H, range, g0uint2int(p));  canvas2d_free (cnv);
      end
  ) end ; if snapshot_hasmore () then window_requestAnimationFrame (step) ;
)
) // end of [window_requestAnimationFrame]

end // end of [local]

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

(*
staload TIME = "libc/SATS/time.sats"
staload STDLIB = "libc/SATS/stdlib.sats"
*)

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

implement
main0 () = let
//
val N = 150
val N = g1ofg0_int (N)
val () = assertloc (N > 0)
//
(*
val () =
$STDLIB.srand48 ($UN.cast{lint}($TIME.time_get()))
*)
//
(*
** Generate a random permutation of the array [1,2,...,N]
*)
//
val A =
  arrayptr_make_intrange (1, N+1)
val p = ptrcast (A)
prval pf = arrayptr_takeout{int} (A)
implement{}
array_permute$randint{n}(n) = g1i2u(randint(g1u2i(n)))
//
val N = i2sz(N)
//
val () = array_permute (!p, N)
//
prval () = arrayptr_addback (pf | A)
//
val A = arrayptr_refize (A)
val A = array0_make_arrayref (A, N)
//
val out = stdout_ref
//
val () = snapshot_push (Normal(A)) where { val A = array0_copy(A) }
//
val () = intqsort (A)
//
val () = snapshot_push (Normal(A)) where { val A = array0_copy (A) }
//
val () = snapshot_reverse ()
//
in
  start_animation ()
end // end of [main0]

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

(* end of [quicksort_anim.dats] *)


Updating: adding some tests for ATS-extsolve-z3

(* ****** ****** *)
//
// Proving that
// append(xs, reverse(xs)) is a palindrome
//
(* ****** ****** *)
//
// Author: HX-2015-06-09
//
(* ****** ****** *)
//
staload
"libats/SATS/ilist_prf.sats"
//
(* ****** ****** *)
//
stacst
append: (ilist, ilist) -> ilist
//
stacst reverse: (ilist) -> ilist
//
(* ****** ****** *)
//
propdef
isPalindrome(xs: ilist) = ILISTEQ(xs, reverse(xs))
//
(* ****** ****** *)
//
extern
prfun
mylemma1{xs:ilist}(): ILISTEQ(xs, reverse(reverse(xs)))
//
(* ****** ****** *)
//
extern
prfun
mylemma2
{xs,ys:ilist}
(
// argumentless
) :
ILISTEQ
(
  reverse(append(xs, ys)), append(reverse(ys), reverse(xs))
) (* end of [mylemma2] *)
//
(* ****** ****** *)
//
extern
prfun
mylemma_main{xs:ilist}(): isPalindrome(append(xs, reverse(xs)))
//
(* ****** ****** *)

primplmnt
mylemma_main
  {xs}() = ILISTEQ() where
{
//
prval ILISTEQ() = mylemma1{xs}()
prval ILISTEQ() = mylemma2{xs,reverse(xs)}()
//
} (* end of [mylemma_main] *)

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

(* end of [palindrome.dats] *)


Updating: continuing work on arduino/LedControl

(*
** LiquidCrystal library
*)

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

%{#
#include \
"arduino/CATS/LedControl/LedControl.cats"
%} // end of [%{#]

(* ****** ****** *)
//
(*
class LedControl
*)
abst@ype
LedControl =
$extype"LedControl"
abstype LedControl_ptr = ptr
//
(* ****** ****** *)
//
fun
LedControl
(
  dataPin: int
, clockPin: int, csPin: int, ndevice: int
) : LedControl_ptr = "mac#" // end-of-fun
//
(* ****** ****** *)

fun
LedControl_getDeviceCount(): int = "mac#"

(* ****** ****** *)
//
fun
LedControl_shutdown
(
  LedControl_ptr, addr: int, status: bool
) : void = "mac#" // end-of-function
//
overload .shutdown with LedControl_shutdown
//
(* ****** ****** *)
//
fun
LedControl_setScanLimit
(
  LedControl_ptr, addr: int, limit: intBtwe(1, 8)
) : void = "mac#" // end-of-function
//
fun
LedControl_setIntensity
(
  LedControl_ptr, addr: int, intensity: intBtw(0, 16)
) : void = "mac#" // end-of-function
//
overload .setScanLimit with LedControl_setScanLimit
overload .setIntensity with LedControl_setIntensity
//
(* ****** ****** *)
//
fun
LedControl_clearDisplay(addr: int): void = "mac#"
//
overload .clearDisplay with LedControl_clearDisplay
//
(* ****** ****** *)
//
fun
LedControl_setLed
(
  addr: int, row: int, col: int, state: bool
) : void = "mac#" // end of [LedControl_setLed]
//
overload .setLed with LedControl_setLed // overload
//
(* ****** ****** *)
//
fun
LedControl_setRow
  (addr: int, row: int, value: byte): void = "mac#"
//
overload .setRow with LedControl_setRow // overload
//
(* ****** ****** *)
//
fun
LedControl_setColumn
  (addr: int, col: int, value: byte): void = "mac#"
//
overload .setColumn with LedControl_setColumn // overload
//
(* ****** ****** *)
//
fun
LedControl_setChar
(
  addr: int, digit: int, value: char, dp: bool
) : void = "mac#" // end of [LedControl_setDigit]
//
overload .setChar with LedControl_setChar // overload
//
fun
LedControl_setDigit
(
  addr: int, digit: int, value: byte, dp: bool
) : void = "mac#" // end of [LedControl_setDigit]
//
overload .setDigit with LedControl_setDigit // overload
//
(* ****** ****** *)

(* end of [LedControl.sats] *)

(*
** LiquidCrystal library
*)

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

%{#
#include \
"arduino/CATS/LedControl/LedControl.cats"
%} // end of [%{#]

(* ****** ****** *)
//
(*
class LedControl
*)
abst@ype
LedControl =
$extype"LedControl"
abstype LedControl_ptr = ptr
//
(* ****** ****** *)

fun
LedControl_getDeviceCount(): int = "mac#"

(* ****** ****** *)
//
fun
LedControl_shutdown
(
  LedControl_ptr, addr: int, status: bool
) : void = "mac#" // end-of-function
//
overload .shutdown with LedControl_shutdown
//
(* ****** ****** *)
//
fun
LedControl_setScanLimit
(
  LedControl_ptr, addr: int, limit: intBtwe(1, 8)
) : void = "mac#" // end-of-function
//
fun
LedControl_setIntensity
(
  LedControl_ptr, addr: int, intensity: intBtw(0, 16)
) : void = "mac#" // end-of-function
//
overload .setScanLimit with LedControl_setScanLimit
overload .setIntensity with LedControl_setIntensity
//
(* ****** ****** *)
//
fun
LedControl_clearDisplay(addr: int): void = "mac#"
//
overload .clearDisplay with LedControl_clearDisplay
//
(* ****** ****** *)

(* end of [LedControl.sats] *)


Upating: improving ATS2-contrib/arduino

Upating: improving ATS2-contrib/arduino

(*
#
# Fade
#
*)
(* ****** ****** *)

(*
/*
 Fade

 This example shows how to fade an LED on pin 9
 using the analogWrite() function.

 This example code is in the public domain.

 */
int brightness = 0;    // how bright the LED is
int fadeAmount = 5;    // how many points to fade the LED by

void setup()  {
  // declare pin 9 to be an output:
  pinMode(9, OUTPUT);
}

void loop()  {
  // set the brightness of pin 9:
  analogWrite(9, brightness);

  // change the brightness for next time through the loop:
  brightness = brightness + fadeAmount;

  // reverse the direction of the fading at the ends of the fade:
  if (brightness == 0 || brightness == 255) {
    fadeAmount = -fadeAmount ;
  }
  // wait for 30 milliseconds to see the dimming effect
  delay(30);
}
*)

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

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#include
"{$ARDUINO}/staloadall.hats"
//
(* ****** ****** *)
//
#define fadeAmount 5
//
(* ****** ****** *)
//
extern
fun
setup (): void = "mac#"
//
implement
setup () =
{
  val () = pinMode(9, OUTPUT)
}
//
(* ****** ****** *)
//
extern
fun
theBrightness_set (n: natLt(256)): void
//
implement
theBrightness_set (n) = analogWrite (9, n)
//
(* ****** ****** *)

fnx
myloop0
(
  n: natLt(256)
) : void = let
  val n2 = n + fadeAmount
  val () = theBrightness_set (n)
  val () = delay (30)
in
  if n2 >= 256
    then myloop1 (n - fadeAmount) else myloop0 (n2)
  // end of [if]
end // end of [myloop0]

and
myloop1
(
  n: natLt(256)
) : void = let
  val n2 = n - fadeAmount
  val () = theBrightness_set (n)
  val () = delay (30)
in
  if n2 >= 0 then myloop1 (n2) else myloop0 (n + fadeAmount)
end // end of [myloop1]

(* ****** ****** *)
//
extern
fun loop (): void = "mac#"
//
implement loop () = myloop0(0)
//
(* ****** ****** *)

(* end of [Fade.dats] *)

(*
#
# Fade
#
*)
(* ****** ****** *)

(*
/*
 Fade

 This example shows how to fade an LED on pin 9
 using the analogWrite() function.

 This example code is in the public domain.

 */
int brightness = 0;    // how bright the LED is
int fadeAmount = 5;    // how many points to fade the LED by

void setup()  {
  // declare pin 9 to be an output:
  pinMode(9, OUTPUT);
}

void loop()  {
  // set the brightness of pin 9:
  analogWrite(9, brightness);

  // change the brightness for next time through the loop:
  brightness = brightness + fadeAmount;

  // reverse the direction of the fading at the ends of the fade:
  if (brightness == 0 || brightness == 255) {
    fadeAmount = -fadeAmount ;
  }
  // wait for 30 milliseconds to see the dimming effect
  delay(30);
}
*)

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

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#include
"{$ARDUINO}/staloadall.hats"
//
(* ****** ****** *)
//
#define fadeAmount 5
//
(* ****** ****** *)
//
extern
fun
setup (): void = "mac#"
//
implement
setup () =
{
  val () = pinMode(9, OUTPUT)
}
//
(* ****** ****** *)
//
extern
fun
theBrightness_set (n: natLt(256)): void
//
implement
theBrightness_set (n) = analogWrite (9, n)
//
(* ****** ****** *)

fnx
myloop0
(
  n: natLt(256)
) : void = let
  val n2 = n + fadeAmount
  val () = theBrightness_set (n)
in
  if n2 >= 256
    then myloop1 (n - fadeAmount) else myloop0 (n2)
  // end of [if]
end // end of [myloop0]

and
myloop1
(
  n: natLt(256)
) : void = let
  val n2 = n - fadeAmount
  val () = theBrightness_set (n)
in
  if n2 >= 0 then myloop1 (n2) else myloop0 (n + fadeAmount)
end // end of [myloop1]

(* ****** ****** *)
//
extern
fun loop (): void = "mac#"
//
implement loop () = myloop0(0)
//
(* ****** ****** *)

(* end of [Fade.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
**
** For testing g-sessions
**
** This famous example is taken from
** a paper on multiparty session types
** by Kohei Honda et al.
**
** Author: Hongwei Xi
** Authoremail: gmhwxiATgmailDOTcom
** Start time: the 8th of March, 2016
**
*)

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

%{^
//
#include <pthread.h>
//
%} // end of [%{^]

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload UN = $UNSAFE

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

staload
UNISTD = "libc/SATS/unistd.sats"

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

staload
"./../SATS/basis_intset.sats"
staload _ =
"./../DATS/basis_intset.dats"

(* ****** ****** *)
//
staload
"./../SATS/basis_ssntype.sats"
staload
"./../SATS/basis_ssntype2r.sats"
//
(* ****** ****** *)
//
staload _ =
"libats/DATS/deqarray.dats"
//
(* ****** ****** *)
//
staload _ =
"libats/DATS/athread.dats"
staload _ =
"libats/DATS/athread_posix.dats"
//
(* ****** ****** *)
//
staload _ =
"./../DATS/basis_uchan.dats"
staload _ =
"./../DATS/basis_channel0.dats"
staload _ =
"./../DATS/basis_channel1.dats"
staload _ =
"./../DATS/basis_ssntype2r.dats"
//
(* ****** ****** *)

#define N 3

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

#define SELLER 0
#define BUYER1 1
#define BUYER2 2

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

typedef title = string
typedef price = double
typedef proof = string
typedef receipt = string

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

typedef
ssn_s0b1b2_succ =
msg(BUYER2,SELLER,proof) ::
msg(SELLER,BUYER2,receipt) :: nil

typedef
ssn_s0b1b2_fail = nil

typedef
ssn_s0b1b2 =
msg(BUYER1,SELLER,title) ::
msg(SELLER,BUYER1,price) ::
msg(SELLER,BUYER2,price) ::
msg(BUYER1,BUYER2,price) ::
choose(BUYER2,ssn_s0b1b2_succ,ssn_s0b1b2_fail)

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

stadef S0 = iset(SELLER)
stadef B1 = iset(BUYER1)
stadef B2 = iset(BUYER2)

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

local
//
prval() =
lemma_iset_sing_is_member{SELLER}()
prval() =
lemma_iset_sing_isnot_member{SELLER,BUYER1}()
prval() =
lemma_iset_sing_isnot_member{SELLER,BUYER2}()
//
prval() = lemma_iset_sing_isnot_nil{SELLER}()
//
in (* in-of-local *)

fun
fserv_seller
(
  chan:
  channel1(S0, N, ssn_s0b1b2)
) : void = let
//
val
title =
channel1_recv_val(chan, BUYER1, SELLER)
val () =
println! ("SELLER: title = ", title)
//
val
price =
(
case+
title of
| "book1" => 100.0
| "book2" => 200.0
| _(*other*) => 500.0
) : price
//
val () =
channel1_send
  (chan, SELLER, BUYER1, price)
val () =
channel1_send
  (chan, SELLER, BUYER2, price)
//
val () = channel1_skipex(chan)
//
val tag =
  channel1_choosetag(chan, BUYER2)
//
in
//
case+ tag of
| choosetag_l() => fserv_seller_succ(chan)
| choosetag_r() => fserv_seller_fail(chan)
//
end (* end of [fserv_seller] *)

and
fserv_seller_succ
(
  chan:
  channel1(S0, N, ssn_s0b1b2_succ)
) : void = let
//
val
proof =
channel1_recv_val(chan, BUYER2, SELLER)
val
receipt = "receipt-for-sale"
val () =
channel1_send(chan, SELLER, BUYER2, receipt)
//
in
  channel1_close(chan)
end (* end of [fserv_seller_succ] *)

and
fserv_seller_fail
(
  chan:
  channel1(S0, N, ssn_s0b1b2_fail)
) : void =
{
  val () = channel1_close(chan)
  val () = println! ("SELLER: no sale is made!")
} (* end of [fserv_seller_fail] *)

end // end of [local]

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

local

val
title_ref = ref<string>("book1")

in
//
fun the_title_get() = !title_ref
fun the_title_set(title: string): void = !title_ref := title
//
end // end of [local]

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

local
//
prval() =
lemma_iset_sing_is_member{BUYER1}()
prval() =
lemma_iset_sing_isnot_member{BUYER1,SELLER}()
prval() =
lemma_iset_sing_isnot_member{BUYER1,BUYER2}()
//
prval() = lemma_iset_sing_isnot_nil{BUYER1}()
//
in (* in-of-local *)

fun
fserv_buyer1
(
  chan:
  channel1(B1, N, ssn_s0b1b2)
) : void = let
//
val
title = the_title_get()
//
val () =
channel1_send
  (chan, BUYER1, SELLER, title)
//
val
price =
channel1_recv_val
  (chan, SELLER, BUYER1)
val () =
println!("BUYER1: price = ", price)
//
val () = channel1_skipex(chan)
//
val () =
channel1_send
  (chan, BUYER1, BUYER2, price / 2)
//
val tag =
  channel1_choosetag(chan, BUYER2)
//
in
//
case+ tag of
| choosetag_l() => fserv_buyer1_succ(chan)
| choosetag_r() => fserv_buyer1_fail(chan)
//
end // end of [fserv_buyer1]

and
fserv_buyer1_succ
(
  chan:
  channel1(B1, N, ssn_s0b1b2_succ)
) : void =
{
  val () = channel1_skipex(chan)
  val () = channel1_skipex(chan)
  val ((*closed*)) = channel1_close(chan)
} (* end of [fserv_buyer1_succ] *)

and
fserv_buyer1_fail
(
  chan:
  channel1(B1, N, ssn_s0b1b2_fail)
) : void =
{
  val ((*closed*)) = channel1_close(chan)
} (* end of [fserv_buyer1_fail] *)

end // end of [local]

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

local
//
prval() =
lemma_iset_sing_is_member{BUYER2}()
prval() =
lemma_iset_sing_isnot_member{BUYER2,SELLER}()
prval() =
lemma_iset_sing_isnot_member{BUYER2,BUYER1}()
//
prval() = lemma_iset_sing_isnot_nil{BUYER2}()
//
in (* in-of-local *)

fun
fserv_buyer2
(
  chan:
  channel1(B2, N, ssn_s0b1b2)
) : void = let
//
val () = channel1_skipex(chan)
val () = channel1_skipex(chan)
//
val
price =
channel1_recv_val
  (chan, SELLER, BUYER2)
val
price2 =
channel1_recv_val
  (chan, BUYER1, BUYER2)
//
val () =
println!("BUYER2: price = ", price)
val () =
println!("BUYER2: price2 = ", price2)
//
val test = (price - price2 <= 100.0)
//
in
//
if test
then {
  val () =
  channel1_choose_l(chan, BUYER2)
  val () = fserv_buyer2_succ(chan)
} (* end of [then] *)
else {
  val () =
  channel1_choose_r(chan, BUYER2)
  val () = fserv_buyer2_fail(chan)
} (* end of [else] *)
//
end (* end of [fserv_buyer2] *)

and
fserv_buyer2_succ
(
  chan:
  channel1(B2, N, ssn_s0b1b2_succ)
) : void = let
//
val
proof = "proof-of-payment"
val () =
channel1_send
  (chan, BUYER2, SELLER, proof)
//
val
receipt =
channel1_recv_val(chan, SELLER, BUYER2)
val () =
println! ("BUYER2: receipt = ", receipt)
//
in
  channel1_close(chan)
end (* end of [fserv_buyer2_succ] *)

and
fserv_buyer2_fail
(
  chan:
  channel1(B2, N, ssn_s0b1b2_fail)
) : void =
{
  val () = channel1_close(chan)
} (* end of [fserv_buyer2_fail] *)

end // end of [local]

(* ****** ****** *)
//
// HX:
//
// Try the following to see difference:
//
// ./S0B1B2 book1
// ./S0B1B2 book2
// ./S0B1B2 book3
//
implement
main0
(
  argc, argv
) = let
//
val () =
if argc >= 2
  then the_title_set(argv[1])
// end of [if]
//
val S0 = intset_int{N}(SELLER)
val B1 = intset_int{N}(BUYER1)
val B2 = intset_int{N}(BUYER2)
//
val chn0 =
cchannel1_create_exn
(
  N, S0, llam(chp) => fserv_seller(chp)
) (* end of [val] *)
val chn2 =
cchannel1_create_exn
(
  N, B2, llam(chp) => fserv_buyer2(chp)
) (* end of [val] *)
//
val () = fserv_buyer1(channel1_link(chn0, chn2))
//
in
  ignoret($UNISTD.usleep(250000u)) // wait for S0 and B2
end // end of [main0]

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

(* end of [S0B1B2.dats] *)

(*
**
** For testing g-sessions
**
** This famous example is taken from
** a paper on multiparty session types
** by Kohei Honda et al.
**
** Author: Hongwei Xi
** Authoremail: gmhwxiATgmailDOTcom
** Start time: the 8th of March, 2016
**
*)

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

%{^
//
#include <pthread.h>
//
%} // end of [%{^]

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload UN = $UNSAFE

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

staload
UNISTD = "libc/SATS/unistd.sats"

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

staload
"./../SATS/basis_intset.sats"
staload _ =
"./../DATS/basis_intset.dats"

(* ****** ****** *)
//
staload
"./../SATS/basis_ssntype.sats"
staload
"./../SATS/basis_ssntype2r.sats"
//
(* ****** ****** *)
//
staload _ =
"libats/DATS/deqarray.dats"
//
(* ****** ****** *)
//
staload _ =
"libats/DATS/athread.dats"
staload _ =
"libats/DATS/athread_posix.dats"
//
(* ****** ****** *)
//
staload _ =
"./../DATS/basis_uchan.dats"
staload _ =
"./../DATS/basis_channel0.dats"
staload _ =
"./../DATS/basis_channel1.dats"
staload _ =
"./../DATS/basis_ssntype2r.dats"
//
(* ****** ****** *)

#define N 3

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

#define SELLER 0
#define BUYER1 1
#define BUYER2 2

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

typedef title = string
typedef price = double
typedef proof = string
typedef receipt = string

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

typedef
ssn_s0b1b2_succ =
msg(BUYER2,SELLER,proof) ::
msg(SELLER,BUYER2,receipt) :: nil

typedef
ssn_s0b1b2_fail = nil

typedef
ssn_s0b1b2 =
msg(BUYER1,SELLER,title) ::
msg(SELLER,BUYER1,price) ::
msg(SELLER,BUYER2,price) ::
msg(BUYER1,BUYER2,price) ::
choose(BUYER2,ssn_s0b1b2_succ,ssn_s0b1b2_fail)

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

stadef S0 = iset(SELLER)
stadef B1 = iset(BUYER1)
stadef B2 = iset(BUYER2)

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

local
//
prval() =
lemma_iset_sing_is_member{SELLER}()
prval() =
lemma_iset_sing_isnot_member{SELLER,BUYER1}()
prval() =
lemma_iset_sing_isnot_member{SELLER,BUYER2}()
//
prval() = lemma_iset_sing_isnot_nil{SELLER}()
//
in (* in-of-local *)

fun
fserv_seller
(
  chan:
  channel1(S0, N, ssn_s0b1b2)
) : void = let
//
val
title =
channel1_recv_val(chan, BUYER1, SELLER)
val () =
println! ("SELLER: title = ", title)
//
val
price =
(
case+
title of
| "book1" => 100.0
| "book2" => 200.0
| _(*other*) => 500.0
) : price
//
val () =
channel1_send
  (chan, SELLER, BUYER1, price)
val () =
channel1_send
  (chan, SELLER, BUYER2, price)
//
val () = channel1_skipex(chan)
//
val tag =
  channel1_choosetag(chan, BUYER2)
//
in
//
case+ tag of
| choosetag_l() => fserv_seller_succ(chan)
| choosetag_r() => fserv_seller_fail(chan)
//
end (* end of [fserv_seller] *)

and
fserv_seller_succ
(
  chan:
  channel1(S0, N, ssn_s0b1b2_succ)
) : void = let
//
val
proof =
channel1_recv_val(chan, BUYER2, SELLER)
val
receipt = "receipt-for-sale"
val () =
channel1_send(chan, SELLER, BUYER2, receipt)
//
in
  channel1_close(chan)
end (* end of [fserv_seller_succ] *)

and
fserv_seller_fail
(
  chan:
  channel1(S0, N, ssn_s0b1b2_fail)
) : void =
{
  val () = channel1_close(chan)
  val () = println! ("SELLER: no sale is made!")
} (* end of [fserv_seller_fail] *)

end // end of [local]

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

local

val
title_ref = ref<string>("book1")

in
//
fun the_title_get() = !title_ref
fun the_title_set(title: string): void = !title_ref := title
//
end // end of [local]

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

local
//
prval() =
lemma_iset_sing_is_member{BUYER1}()
prval() =
lemma_iset_sing_isnot_member{BUYER1,SELLER}()
prval() =
lemma_iset_sing_isnot_member{BUYER1,BUYER2}()
//
prval() = lemma_iset_sing_isnot_nil{BUYER1}()
//
in (* in-of-local *)

fun
fserv_buyer1
(
  chan:
  channel1(B1, N, ssn_s0b1b2)
) : void = let
//
val
title = the_title_get()
//
val () =
channel1_send
  (chan, BUYER1, SELLER, title)
//
val
price =
channel1_recv_val
  (chan, SELLER, BUYER1)
val () =
println!("BUYER1: price = ", price)
//
val () = channel1_skipex(chan)
//
val () =
channel1_send
  (chan, BUYER1, BUYER2, price / 2)
//
val tag =
  channel1_choosetag(chan, BUYER2)
//
in
//
case+ tag of
| choosetag_l() => fserv_buyer1_succ(chan)
| choosetag_r() => fserv_buyer1_fail(chan)
//
end // end of [fserv_buyer1]

and
fserv_buyer1_succ
(
  chan:
  channel1(B1, N, ssn_s0b1b2_succ)
) : void =
{
  val () = channel1_skipex(chan)
  val () = channel1_skipex(chan)
  val ((*closed*)) = channel1_close(chan)
} (* end of [fserv_buyer1_succ] *)

and
fserv_buyer1_fail
(
  chan:
  channel1(B1, N, ssn_s0b1b2_fail)
) : void =
{
  val ((*closed*)) = channel1_close(chan)
} (* end of [fserv_buyer1_fail] *)

end // end of [local]

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

local
//
prval() =
lemma_iset_sing_is_member{BUYER2}()
prval() =
lemma_iset_sing_isnot_member{BUYER2,SELLER}()
prval() =
lemma_iset_sing_isnot_member{BUYER2,BUYER1}()
//
prval() = lemma_iset_sing_isnot_nil{BUYER2}()
//
in (* in-of-local *)

fun
fserv_buyer2
(
  chan:
  channel1(B2, N, ssn_s0b1b2)
) : void = let
//
val () = channel1_skipex(chan)
val () = channel1_skipex(chan)
//
val
price =
channel1_recv_val
  (chan, SELLER, BUYER2)
val
price2 =
channel1_recv_val
  (chan, BUYER1, BUYER2)
//
val () =
println!("BUYER2: price = ", price)
val () =
println!("BUYER2: price2 = ", price2)
//
val test = (price - price2 <= 100.0)
//
in
//
if test
then {
  val () =
  channel1_choose_l(chan, BUYER2)
  val () = fserv_buyer2_succ(chan)
} (* end of [then] *)
else {
  val () =
  channel1_choose_r(chan, BUYER2)
  val () = fserv_buyer2_fail(chan)
} (* end of [else] *)
//
end (* end of [fserv_buyer2] *)

and
fserv_buyer2_succ
(
  chan:
  channel1(B2, N, ssn_s0b1b2_succ)
) : void = let
//
val
proof = "proof-of-payment"
val () =
channel1_send
  (chan, BUYER2, SELLER, proof)
//
val
receipt =
channel1_recv_val(chan, SELLER, BUYER2)
val () =
println! ("BUYER2: receipt = ", receipt)
//
in
  channel1_close(chan)
end (* end of [fserv_buyer2_succ] *)

and
fserv_buyer2_fail
(
  chan:
  channel1(B2, N, ssn_s0b1b2_fail)
) : void =
{
  val () = channel1_close(chan)
} (* end of [fserv_buyer2_fail] *)

end // end of [local]

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

implement
main0
(
  argc, argv
) = let
//
val () =
if argc >= 2
  then the_title_set(argv[1])
// end of [if]
//
val S0 = intset_int{N}(SELLER)
val B1 = intset_int{N}(BUYER1)
val B2 = intset_int{N}(BUYER2)
//
val chn0 =
cchannel1_create_exn
(
  N, S0, llam(chp) => fserv_seller(chp)
) (* end of [val] *)
val chn2 =
cchannel1_create_exn
(
  N, B2, llam(chp) => fserv_buyer2(chp)
) (* end of [val] *)
//
val () =
fserv_buyer1
  ($UN.castvwtp0(channel1_link(chn0, chn2)))
//
in
  ignoret($UNISTD.usleep(250000u)) // wait for S0 and B2
end // end of [main0]

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

(* end of [S0B1B2.dats] *)


Updating: very minorly fixing

Updating: very minorly fixing

(* ****** ****** *)
//
// HX-2015-03-20:
//
// Animating a variant of
// the Dining Philosophers problem
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)

#define ATS_MAINATSFLAG 1
#define ATS_DYNLOADNAME "my_dynload"

(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
staload
"{$LIBATSCC2JS}/SATS/HTML/canvas-2d/canvas2d.sats"
//
(* ****** ****** *)
//
#define NPHIL 5
typedef nphil = natLt(NPHIL)
//
(* ****** ****** *)
//
extern
fun theCtx2d_get(): canvas2d = "mac#"
//
(* ****** ****** *)
//
extern
fun
cloref_app
(
  fwork: () -<cloref1> void
) : void = "mac#" // endfun
//
implement cloref_app(fwork) = fwork()
//
extern
fun
setTimeout_cloref
(
  fwork: () -<cloref1> void, ntime: double
) : void = "mac#" // end-of-function
//
(* ****** ****** *)
//
fun
rand_int2
(
  x0: int, len: intGte(0)
) : double =
(
  x0 + len * JSmath_random()
)
//
(* ****** ****** *)

extern
fun
phil_draw(id: nphil): void = "mac#"

(* ****** ****** *)
//
extern
fun
phil_pick_lfork(id: nphil): int = "mac#"
and
phil_pick_rfork(id: nphil): int = "mac#"
//
extern
fun
phil_return_lfork(id: nphil): void = "mac#"
and
phil_return_rfork(id: nphil): void = "mac#"
//
(* ****** ****** *)
//
extern
fun
phil_loop (id: nphil): void = "mac#"
//
extern
fun phil_think_beg (id: nphil): void
and phil_think_end (id: nphil): void
//
extern
fun phil_dine_start (id: nphil): void
and phil_dine_lfork (id: nphil): void
and phil_dine_rfork (id: nphil): void
and phil_dine_finish (id: nphil): void
//
(* ****** ****** *)
//
implement
phil_loop(id) =
  (phil_draw(id); phil_think_beg (id))
//
(* ****** ****** *)
//
implement
phil_think_beg
  (id) = let
//
val ntime = rand_int2(500, 2500)
//
in
//
setTimeout_cloref(lam() => phil_think_end(id), ntime)
//
end // end of [phil_think_beg]
//
implement phil_think_end(id) = phil_dine_start(id)
//
(* ****** ****** *)
//
implement
phil_dine_start
  (id) = phil_dine_lfork(id)
//
implement
phil_dine_lfork
  (id) = let
//
val ntime =
  rand_int2(250, 1000)
//
val lfork = phil_pick_lfork(id)
val ((*void*)) = if lfork > 0 then phil_draw(id)
//
in
//
if
lfork = 0
then setTimeout_cloref(lam() => phil_dine_lfork(id), ntime)
else setTimeout_cloref(lam() => phil_dine_rfork(id), ntime)
//
end // end of [phil_dine_lfork]
//
implement
phil_dine_rfork(id) = let
//
val ntime =
  rand_int2(250, 1000)
//
val rfork = phil_pick_rfork(id)
val ((*void*)) = if rfork > 0 then phil_draw(id)
//
in
//
if
rfork = 0
then setTimeout_cloref(lam() => phil_dine_rfork(id), ntime)
else setTimeout_cloref(lam() => phil_dine_finish(id), ntime)
//
end // end of [phil_dine_rfork]

implement
phil_dine_finish(id) =
(
  phil_return_lfork(id); phil_return_rfork(id); phil_loop(id)
)
//
(* ****** ****** *)

%{$
//
var
mycanvas =
document.getElementById
  ("Patsoptaas-Evaluate-canvas");
//
var
myctx2d0 = mycanvas.getContext( '2d' );
//
var theFks = [1, 1, 1, 1, 1]
//
var Ph0 = { lfork: 0, rfork: 0 }
var Ph1 = { lfork: 0, rfork: 0 }
var Ph2 = { lfork: 0, rfork: 0 }
var Ph3 = { lfork: 0, rfork: 0 }
var Ph4 = { lfork: 0, rfork: 0 }
var thePhs = [Ph0, Ph1, Ph2, Ph3, Ph4]
//
function
phil_pick_lfork
  (id0)
{
//
var
lf0 =
theFks[id0];
if(lf0 > 0)
{
  theFks[id0] = 0;
  thePhs[id0].lfork = 1;
}
return (lf0);
//
} // phil_pick_lfork
//
function
phil_pick_rfork
  (id0)
{
//
var id1 = (id0+1)%5;
var rf1 = theFks[id1];
if(rf1 > 0)
{
  theFks[id1] = 0;
  thePhs[id0].rfork = 1;
}
return (rf1);
//
} // phil_pick_rfork
//
function
phil_return_lfork
  (id0)
{
  var ph = thePhs[id0];
  ph.lfork = 0; theFks[id0] = 1; return;
}
function
phil_return_rfork
  (id0)
{
  var ph = thePhs[id0];
  var id1 = (id0+1)%5
  ph.rfork = 0; theFks[id1] = 1; return;
}
//
function
theCx_get() { return mycanvas.width/2; }
function
theCy_get() { return mycanvas.height/2; }
function
theRadius1_get() { return Math.min(mycanvas.width, mycanvas.height)/2; }
function
theRadius2_get() { return theRadius1_get() / 5; }
//
function
phil_Cx(id)
{
  var r1 = theRadius1_get();
  var r2 = theRadius2_get();
  var theta = Math.PI/2 - id*(2*Math.PI/5);
  return theCx_get() + (r1-r2) * Math.cos(theta);
}
function
phil_Cy(id)
{
  var r1 = theRadius1_get();
  var r2 = theRadius2_get();
  var theta = Math.PI/2 - id*(2*Math.PI/5);
  return theCy_get() - (r1-r2) * Math.sin(theta);
}
//
function
phil_draw(id)
{
  var ph = thePhs[id];
  var Cx = phil_Cx(id);
  var r2 = theRadius2_get();
  var Cy = phil_Cy(id) + 2*r2/5;
  var fg_color = "#000000"; // black
  var bg_color = "#ffffff"; // white
//
  var PI = Math.PI
//
  myctx2d0.beginPath();
  myctx2d0.arc(Cx, Cy, r2, 0, 2*PI, true);
  myctx2d0.closePath();
  myctx2d0.fillStyle = bg_color; myctx2d0.fill();
//
  if (ph.lfork > 0)
  {
    myctx2d0.beginPath();
    myctx2d0.arc(Cx, Cy, r2, 3*PI/2, 1*PI/2, true);
    myctx2d0.closePath();
    myctx2d0.fillStyle = fg_color; myctx2d0.fill();
  }
  if (ph.rfork > 0)
  {
    myctx2d0.beginPath();
    myctx2d0.arc(Cx, Cy, r2, 1*PI/2, 3*PI/2, true);
    myctx2d0.closePath();
    myctx2d0.fillStyle = fg_color; myctx2d0.fill();
  }
//
  return;
}
//
function
DininingPhil_initize()
{
  phil_loop(0);
  phil_loop(1);
  phil_loop(2);
  phil_loop(3);
  phil_loop(4); return;
}
/*
function
DininingPhil_initize() { alert("DininingPhil_initize"); }
*/
//
function
setTimeout_cloref(fwork, ntime)
{
  setTimeout(function(){cloref_app(fwork);return;}, ntime); return;
}
//
jQuery(document).ready(function(){DininingPhil_initize();});
//
%} // end of [%{$]

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

(* end of [DiningPhil.php] *)

(* ****** ****** *)
//
// HX-2015-03-20:
//
// Animating a variant of
// the Dining Philosophers problem
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)

#define ATS_MAINATSFLAG 1
#define ATS_DYNLOADNAME "my_dynload"

(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
staload
"{$LIBATSCC2JS}/SATS/HTML/canvas-2d/canvas2d.sats"
//
(* ****** ****** *)
//
#define NPHIL 5
typedef nphil = natLt(NPHIL)
//
(* ****** ****** *)
//
extern
fun theCtx2d_get(): canvas2d = "mac#"
//
(* ****** ****** *)
//
extern
fun
cloref_app
(
  fwork: () -<cloref1> void
) : void = "mac#" // endfun
//
implement cloref_app(fwork) = fwork()
//
extern
fun
setTimeout_cloref
(
  fwork: () -<cloref1> void, ntime: double
) : void = "mac#" // end-of-function
//
(* ****** ****** *)
//
fun
rand_int2
(
  x0: int, len: intGte(0)
) : double =
(
  x0 + len * JSmath_random()
)
//
(* ****** ****** *)

extern
fun
phil_draw(id: nphil): void = "mac#"

(* ****** ****** *)
//
extern
fun
phil_pick_lfork(id: nphil): int = "mac#"
and
phil_pick_rfork(id: nphil): int = "mac#"
//
extern
fun
phil_return_lfork(id: nphil): void = "mac#"
and
phil_return_rfork(id: nphil): void = "mac#"
//
(* ****** ****** *)
//
extern
fun
phil_loop (id: nphil): void = "mac#"
//
extern
fun phil_think_beg (id: nphil): void
and phil_think_end (id: nphil): void
//
extern
fun phil_dine_start (id: nphil): void
and phil_dine_lfork (id: nphil): void
and phil_dine_rfork (id: nphil): void
and phil_dine_finish (id: nphil): void
//
(* ****** ****** *)
//
implement
phil_loop(id) =
  (phil_draw(id); phil_think_beg (id))
//
(* ****** ****** *)
//
implement
phil_think_beg
  (id) = let
//
val ntime = rand_int2(500, 2500)
//
in
//
setTimeout_cloref(lam() => phil_think_end(id), ntime)
//
end // end of [phil_think_beg]
//
implement phil_think_end(id) = phil_dine_start(id)
//
(* ****** ****** *)
//
implement
phil_dine_start
  (id) = phil_dine_lfork(id)
//
implement
phil_dine_lfork
  (id) = let
//
val ntime =
  rand_int2(250, 1000)
//
val lfork = phil_pick_lfork(id)
val ((*void*)) = if lfork > 0 then phil_draw(id)
//
in
//
if
lfork = 0
then setTimeout_cloref(lam() => phil_dine_lfork(id), ntime)
else setTimeout_cloref(lam() => phil_dine_rfork(id), ntime)
//
end // end of [phil_dine_lfork]
//
implement
phil_dine_rfork(id) = let
//
val ntime =
  rand_int2(250, 1000)
//
val rfork = phil_pick_rfork(id)
val ((*void*)) = if rfork > 0 then phil_draw(id)
//
in
//
if
rfork = 0
then setTimeout_cloref(lam() => phil_dine_rfork(id), ntime)
else setTimeout_cloref(lam() => phil_dine_finish(id), ntime)
//
end // end of [phil_dine_rfork]

implement
phil_dine_finish(id) =
(
  phil_return_lfork(id); phil_return_rfork(id); phil_loop(id)
)
//
(* ****** ****** *)

%{$
//
var
mycanvas =
document.getElementById
  ("Patsoptaas-Evaluate-canvas");
//
var
myctx2d0 = mycanvas.getContext( '2d' );
//
var theFks = [1, 1, 1, 1, 1]
//
var Ph0 = { lfork: 0, rfork: 0 }
var Ph1 = { lfork: 0, rfork: 0 }
var Ph2 = { lfork: 0, rfork: 0 }
var Ph3 = { lfork: 0, rfork: 0 }
var Ph4 = { lfork: 0, rfork: 0 }
var thePhs = [Ph0, Ph1, Ph2, Ph3, Ph4]
//
function
phil_pick_lfork
  (id0)
{
//
var
lf0 =
theFks[id0];
if(lf0 > 0)
{
  theFks[id0] = 0;
  thePhs[id0].lfork = 1;
}
return (lf0);
//
} // phil_pick_lfork
//
function
phil_pick_rfork
  (id0)
{
//
var id1 = (id0+1)%5;
var rf1 = theFks[id1];
if(rf1 > 0)
{
  theFks[id1] = 0;
  thePhs[id0].rfork = 1;
}
return (rf1);
//
} // phil_pick_rfork
//
function
phil_return_lfork
  (id0)
{
  var ph = thePhs[id0];
  ph.lfork = 0; theFks[id0] = 1; return;
}
function
phil_return_rfork
  (id0)
{
  var ph = thePhs[id0];
  var id1 = (id0+1)%5
  ph.rfork = 0; theFks[id1] = 1; return;
}
//
function
theCx_get() { return mycanvas.width/2; }
function
theCy_get() { return mycanvas.height/2; }
function
theRadius1_get() { return Math.min(mycanvas.width, mycanvas.height)/2; }
function
theRadius2_get() { return theRadius1_get() / 5; }
//
function
phil_Cx(id)
{
  var r1 = theRadius1_get();
  var r2 = theRadius2_get();
  var theta = Math.PI/2 - id*(2*Math.PI/5);
  return theCx_get() + (r1-r2) * Math.cos(theta);
}
function
phil_Cy(id)
{
  var r1 = theRadius1_get();
  var r2 = theRadius2_get();
  var theta = Math.PI/2 - id*(2*Math.PI/5);
  return theCy_get() - (r1-r2) * Math.sin(theta);
}
//
function
phil_draw(id)
{
  var ph = thePhs[id];
  var Cx = phil_Cx(id);
  var r2 = theRadius2_get();
  var Cy = phil_Cy(id) + 2*r2/5;
  var fg_color = "#000000"; // black
  var bg_color = "#ffffff"; // white
//
  var PI = Math.PI
//
  myctx2d0.beginPath();
  myctx2d0.arc(Cx, Cy, r2, 0, 2*PI, true);
  myctx2d0.closePath();
  myctx2d0.fillStyle = bg_color; myctx2d0.fill();
//
  if (ph.lfork > 0)
  {
    myctx2d0.beginPath();
    myctx2d0.arc(Cx, Cy, r2, 1*PI/2, 3*PI/2, true);
    myctx2d0.closePath();
    myctx2d0.fillStyle = fg_color; myctx2d0.fill();
  }
  if (ph.rfork > 0)
  {
    myctx2d0.beginPath();
    myctx2d0.arc(Cx, Cy, r2, 3*PI/2, 1*PI/2, true);
    myctx2d0.closePath();
    myctx2d0.fillStyle = fg_color; myctx2d0.fill();
  }
//
  return;
}
//
function
DininingPhil_initize()
{
  phil_loop(0);
  phil_loop(1);
  phil_loop(2);
  phil_loop(3);
  phil_loop(4); return;
}
/*
function
DininingPhil_initize() { alert("DininingPhil_initize"); }
*/
//
function
setTimeout_cloref(fwork, ntime)
{
  setTimeout(function(){cloref_app(fwork);return;}, ntime); return;
}
//
jQuery(document).ready(function(){DininingPhil_initize();});
//
%} // end of [%{$]

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

(* end of [DiningPhil.php] *)