Modify Pin.sats.

Modify Pin.sats.

// Pin control drivers

staload "Bit.sats"

datasort IOPort =
 | Port0 of () | Port1 of () | Port2 of () | Port3 of ()
 | Port4 of () | Port5 of () | Port6 of () | Port7 of ()
 | Port8 of () | Port9 of () | PortA of () | PortB of ()
 | PortC of () | PortD of () | PortE of () | PortF of ()
 | PortG of () | PortH of () | PortI of () | PortJ of ()

stadef IOPort2int (p:IOPort):int =
  ifint (p==Port0, 0, ifint (p==Port1, 1,
  ifint (p==Port2, 2, ifint (p==Port3, 3,
  ifint (p==Port4, 4, ifint (p==Port5, 5,
  ifint (p==Port6, 6, ifint (p==Port7, 7,
  ifint (p==Port8, 8, ifint (p==Port9, 9,
  ifint (p==PortA,10, ifint (p==PortB,11,
  ifint (p==PortC,12, ifint (p==PortD,13,
  ifint (p==PortE,14, ifint (p==PortF,15,
  ifint (p==PortG,16, ifint (p==PortH,17,
  ifint (p==PortI,18, ifint (p==PortJ,19,
  ~1))))))))))))))))))))

typedef ioport_uint_t (p:IOPort) = uint (IOPort2int p)

datasort Pin = Pin of (IOPort,int)

typedef pin_uint_t (p:IOPort,n:int) = @(ioport_uint_t p, uint n)

stadef P0 (n:int):Pin = Pin (Port0,n)
stadef P1 (n:int):Pin = Pin (Port1,n)
stadef P2 (n:int):Pin = Pin (Port2,n)
stadef P3 (n:int):Pin = Pin (Port3,n)
stadef P4 (n:int):Pin = Pin (Port4,n)
stadef P5 (n:int):Pin = Pin (Port5,n)
stadef P6 (n:int):Pin = Pin (Port6,n)
stadef P7 (n:int):Pin = Pin (Port7,n)
stadef P8 (n:int):Pin = Pin (Port8,n)
stadef P9 (n:int):Pin = Pin (Port9,n)
stadef PA (n:int):Pin = Pin (PortA,n)
stadef PB (n:int):Pin = Pin (PortB,n)
stadef PC (n:int):Pin = Pin (PortC,n)
stadef PD (n:int):Pin = Pin (PortD,n)
stadef PE (n:int):Pin = Pin (PortE,n)
stadef PF (n:int):Pin = Pin (PortF,n)
stadef PG (n:int):Pin = Pin (PortG,n)
stadef PH (n:int):Pin = Pin (PortH,n)
stadef PI (n:int):Pin = Pin (PortI,n)
stadef PJ (n:int):Pin = Pin (PortJ,n)

// Special form of fractional (n/2^m only)
datasort bisectional = bisectional of (int,int)

stadef bisect1 = bisectional (0,1)

dataprop EQBISECTIONAL (bisectional, bisectional) = {r:bisectional} EQBISECTIONAL (r, r)
praxi eqbisectional_make {r,s:bisectional | r == s} () : EQBISECTIONAL (r,s)
praxi bisectional_eq_refl {r:bisectional} () : [r == r] void
praxi bisectional_eq_reduce {n,m:int | n <= INTMAX_HALF} ():
      [bisectional (n,m) == bisectional (n+n,m+1)] void

stacst bisectional_add_b : (bisectional,bisectional,bisectional) -> bool

praxi {n1,n2,m:int} bisectional_add_axi ():
      [bisectional_add_b (bisectional (n1,m),bisectional (n2,m),bisectional (n1+n2,m))] unit_p

stacst bisectional_half_b : (bisectional,bisectional) -> bool

praxi {n,m:int} bisectional_half_axi ():
      [bisectional_half_b (bisectional (n,m),bisectional (n,m+1))] unit_p

// PMR

absview PMR_BIT_V (Pin,bit,bisectional)

praxi {p:Pin}{b:bit} divide_pmr_bit_v {r,s:bisectional | bisectional_half_b (r,s)}
      (PMR_BIT_V (p,b,r)) : (PMR_BIT_V (p,b,s),PMR_BIT_V (p,b,s))

praxi {p:Pin}{b:bit} merge_pmr_bit_v {r,s,t:bisectional | bisectional_add_b (r,s,t)}
      (PMR_BIT_V (p,b,r), PMR_BIT_V (p,b,s)):(PMR_BIT_V (p,b,t))

stadef PMR_BIT_IOPORT     = O
stadef PMR_BIT_PERIPHERAL = I

dataview PMR_V (IOPort,bits) =
    {p:IOPort}{b7,b6,b5,b4,b3,b2,b1,b0:bit}
    PMR_V (p,Bits8 (b7,b6,b5,b4,b3,b2,b1,b0)) of
      (PMR_BIT_V (Pin (p,7),b0,bisect1), PMR_BIT_V (Pin (p,6),b1,bisect1),
       PMR_BIT_V (Pin (p,5),b2,bisect1), PMR_BIT_V (Pin (p,4),b3,bisect1),
       PMR_BIT_V (Pin (p,3),b4,bisect1), PMR_BIT_V (Pin (p,2),b5,bisect1),
       PMR_BIT_V (Pin (p,1),b6,bisect1), PMR_BIT_V (Pin (p,0),b7,bisect1))

absprop PMR_PERMISSION (IOPort,bit_permissions)

propdef PMR_PERMIT (p:IOPort,bs:bits) =
    [perms:bit_permissions]
    (PMR_PERMISSION (p,perms),BITS_PERMIT_CERTIFICATE (8,perms,bs))

fn {bs,cs:bits}{p:IOPort}
  writePMR (PMR_V (p,bs), PMR_PERMIT (p,cs) | ioport_uint_t p, bits_uint_t (8,cs))
   :(PMR_V (p,cs) | void)

fn {bs,cs:bits}{p:IOPort}{b:bit}
  changePMRBit {bn:int | bn < 8}
    (CHANGE_BIT_BITS (8,bs,bn,b,cs),
     !PMR_V (p,bs) >> PMR_V (p,cs),
     PMR_PERMIT (p,cs)
    | pin_uint_t (p,bn), bit_uint_t b):void

fn {bs:bits}{p:IOPort}
  readPMR (!PMR_V (p,bs) | p:ioport_uint_t p)
   :bits_uint_t (8,bs)

fn {p:IOPort}{n:int}{b:bit}{r:bisectional}
  readPMRbit (!PMR_BIT_V (Pin (p,n),b,r) | pin:pin_uint_t (p,n))
   :bool (b==I)

// The PFS function is postponed.
// Define only PFS_V so that other functions can acquire the state of the initial value
(*
// PWPR

absview PWPR_V (bits)

fn writePWPR {
    pfswe,b0wi,PFSWE,B0WI:bit
    | (pfswe==PFSWE) || (b0wi==O && B0WI==O)
  }(
    !PWPR_V (Bits8 (b0wi,pfswe,O,O,O,O,O,O)) >>
     PWPR_V (Bits8 (B0WI,PFSWE,O,O,O,O,O,O)) |
     bits8int_t (B0WI,PFSWE,O,O,O,O,O,O)
  ):void

fn {pfswe,b0wi:bit}
  readPWPR (!PWPR_V (Bits8 (b0wi,pfswe,O,O,O,O,O,O)))
   :bits8int_t (b0wi,pfswe,O,O,O,O,O,O)
*)

// PFS

absview PFS_V (Pin,bits)
(*
fn {p:IOPort}{pnum:int}
   {b0wi,asel,isel,psel4,psel3,psel2,psel1,psel0:bit}
  writePFS (
    !PWPR_V (Bits8 (O,O,O,O,O,O,I,b0wi)),
    !PFS_V (Pin (p,pnum),Bits8 (asel,isel,O,psel4,psel3,psel2,psel1,psel0)) >>
     PFS_V (Pin (p,pnum),Bits8 (O,O,O,O,O,O,O,O)),
    !PMR_BIT_V (Pin (p,pnum), O)
  | pin_uint_t (p,pnum),
    bits8int_t (O,O,O,O,O,O,O,O)
  )
  :void

fn {p:IOPort}{pnum:int}{asel,isel,psel4,psel3,psel2,psel1,psel0:bit}
  readPFS (
    !PFS_V (Pin (p,pnum),Bits8 (asel,isel,O,psel4,psel3,psel2,psel1,psel0))
  | pin_uint_t (p, pnum)
  )
  :bits8int_t (asel,isel,O,psel4,psel3,psel2,psel1,psel0)
*)

// TODO Create duplicate prohibited view of peripheral devices.
//      Issues view with no device assignment pins first.
//       Propriety of writing / disabling per pins is required.

// PDR

stadef PDR_BIT_WRITABLE  = I
stadef PDR_BIT_READ_ONLY = O

absview PDR_BIT_V (Pin,bit,bisectional)

praxi {p:Pin}{b:bit} divide_pdr_bit_v {r,s:bisectional | bisectional_half_b (r,s)}
      (PDR_BIT_V (p,b,r)) : (PDR_BIT_V (p,b,s),PDR_BIT_V (p,b,s))

praxi {p:Pin}{b:bit} merge_pdr_bit_v {r,s,t:bisectional | bisectional_add_b (r,s,t)}
      (PDR_BIT_V (p,b,r), PDR_BIT_V (p,b,s)):(PDR_BIT_V (p,b,t))

dataview PDR_V (p:IOPort,bits) =
    {p:IOPort}{b7,b6,b5,b4,b3,b2,b1,b0:bit}
    PDR_V (p,Bits8 (b7,b6,b5,b4,b3,b2,b1,b0)) of
      (PDR_BIT_V (Pin (p,7),b0,bisect1), PDR_BIT_V (Pin (p,6),b1,bisect1),
       PDR_BIT_V (Pin (p,5),b2,bisect1), PDR_BIT_V (Pin (p,4),b3,bisect1),
       PDR_BIT_V (Pin (p,3),b4,bisect1), PDR_BIT_V (Pin (p,2),b5,bisect1),
       PDR_BIT_V (Pin (p,1),b6,bisect1), PDR_BIT_V (Pin (p,0),b7,bisect1))

absprop PDR_PERMISSION (IOPort,bit_permissions)

propdef PDR_PERMIT (p:IOPort,bs:bits) =
    [perms:bit_permissions]
    (PDR_PERMISSION (p,perms),BITS_PERMIT_CERTIFICATE (8,perms,bs))

fn {p:IOPort}{bs,cs:bits}{v: int}
  writePDR (PDR_PERMIT (p,cs),
            !PDR_V (p,bs) >> PDR_V (p,cs) |
            ioport_uint_t p,bits_uint_t (8,cs)):void

fn {p:IOPort}{bs:bits}
  readPDR (!PDR_V (p,bs) | ioport_uint_t p)
   : bits_uint_t (8,bs)

fn {p:IOPort}{n:int}{b:bit}{r:bisectional}
  readPDRbit (!PDR_BIT_V (Pin (p,n),b,r) | pin:pin_uint_t (p,n))
   :bool (b==I)

// PODR

stadef PODR_BIT_HIGH   = I
stadef PODR_BIT_GROUND = O

absview PODR_BIT_V (Pin,bit,bisectional)

praxi {p:Pin}{b:bit} divide_podr_bit_v {r,s:bisectional | bisectional_half_b (r,s)}
      (PODR_BIT_V (p,b,r)) : (PODR_BIT_V (p,b,s),PODR_BIT_V (p,b,s))

praxi {p:Pin}{b:bit} merge_podr_bit_v {r,s,t:bisectional | bisectional_add_b (r,s,t)}
    (PODR_BIT_V (p,b,r), PODR_BIT_V (p,b,s)):(PODR_BIT_V (p,b,t))

dataview PODR_V (p:IOPort,bits) =
    {p:IOPort}{b7,b6,b5,b4,b3,b2,b1,b0:bit}
    PODR_V (p,Bits8 (b7,b6,b5,b4,b3,b2,b1,b0)) of
      (PODR_BIT_V (Pin (p,7),b0,bisect1), PODR_BIT_V (Pin (p,6),b1,bisect1),
       PODR_BIT_V (Pin (p,5),b2,bisect1), PODR_BIT_V (Pin (p,4),b3,bisect1),
       PODR_BIT_V (Pin (p,3),b4,bisect1), PODR_BIT_V (Pin (p,2),b5,bisect1),
       PODR_BIT_V (Pin (p,1),b6,bisect1), PODR_BIT_V (Pin (p,0),b7,bisect1))

absprop PODR_PERMISSION (IOPort,bit_permissions)

propdef PODR_PERMIT (p:IOPort,bs:bits) =
    [perms:bit_permissions]
    (PODR_PERMISSION (p,perms),BITS_PERMIT_CERTIFICATE (8,perms,bs))

fn {p:IOPort}{bs,cs:bits}
  writePODR (PODR_PERMIT (p,cs),
             !PODR_V (p,bs) >> PODR_V (p,cs) |
             ioport_uint_t p, bits_uint_t (8,cs)):void

fn {p:IOPort}{bs:bits}
  readPODR (PODR_V (p,bs) | ioport_uint_t p)
   :bits_uint_t (8,bs)

fn {p:IOPort}{n:int}{b:bit}{r:bisectional}
  readPODRbit (!PODR_BIT_V (Pin (p,n),b,r) | pin:pin_uint_t (p,n))
   :bool (b==I)

// PIDR

absprop PIDR_BIT_P (Pin,bit)
dataprop PIDR_P (p:IOPort,bits) =
    {p:IOPort}{b7,b6,b5,b4,b3,b2,b1,b0:bit}
    PIDR_P (p,Bits8 (b7,b6,b5,b4,b3,b2,b1,b0)) of
      (PIDR_BIT_P (Pin (p,7),b0), PIDR_BIT_P (Pin (p,6),b1),
       PIDR_BIT_P (Pin (p,5),b2), PIDR_BIT_P (Pin (p,4),b3),
       PIDR_BIT_P (Pin (p,3),b4), PIDR_BIT_P (Pin (p,2),b5),
       PIDR_BIT_P (Pin (p,1),b6), PIDR_BIT_P (Pin (p,0),b7))

fn {p:IOPort} readPIDR (ioport_uint_t p)
   :[bs:bits] (PIDR_P (p,bs) | bits_uint_t (8,bs))

// GPIO

viewdef PinOutputView (p:Pin,output:bit) =
  [isel:bit][s,r,t:bisectional]
  (PFS_V (p,Bits8 (O,isel,O,O,O,O,O,O)),
   PMR_BIT_V (p,O,s),PDR_BIT_V (p,I,r),PODR_BIT_V (p,output,t))

absprop PinInput (Pin,bit)

fn readPinInput {p:IOPort}{n:int}{isel:bit}{s,r:bisectional}
   (PFS_V (Pin (p,n),Bits8 (O,isel,O,O,O,O,O,O)),
   !PMR_BIT_V (Pin (p,n),O,s),!PDR_BIT_V (Pin (p,n),O,r) | pin_uint_t (p,n))
   : [input:bit] (PinInput (Pin (p,n),input) | bool (input==I))

////

// TODO Make a view expressing the setting of output voltage and open drain etc.
(*
fn getInitialPinViews () : //<lin>
    (GPIOView (P0 0,O,I),
     GPIOView (P0 1,I,O),
     GPIOView (P1 0,O,O),
     GPIOView (P1 1,I,I)
     | void)
*)

// TODO make initial absprops.
////
fn rx110_64pins_initial_views ():<lin> (
    PODR_PERMISSION (Port0,BitPermissions8 (Permit,Permit,Permit,Permit,Permit,Permit,Permit,Permit)),
    PODR_V          (Port0,Bits8(O,O,O,O,O,O,O,O)),

)

// 端子制御ドライバ定義

staload "Bit.sats"

datasort IOPort =
 | Port0 of () | Port1 of () | Port2 of () | Port3 of ()
 | Port4 of () | Port5 of () | Port6 of () | Port7 of ()
 | Port8 of () | Port9 of () | PortA of () | PortB of ()
 | PortC of () | PortD of () | PortE of () | PortF of ()
 | PortG of () | PortH of () | PortI of () | PortJ of ()

stadef IOPort2int (p:IOPort):int =
  ifint (p==Port0, 0, ifint (p==Port1, 1,
  ifint (p==Port2, 2, ifint (p==Port3, 3,
  ifint (p==Port4, 4, ifint (p==Port5, 5,
  ifint (p==Port6, 6, ifint (p==Port7, 7,
  ifint (p==Port8, 8, ifint (p==Port9, 9,
  ifint (p==PortA,10, ifint (p==PortB,11,
  ifint (p==PortC,12, ifint (p==PortD,13,
  ifint (p==PortE,14, ifint (p==PortF,15,
  ifint (p==PortG,16, ifint (p==PortH,17,
  ifint (p==PortI,18, ifint (p==PortJ,19,
  ~1))))))))))))))))))))

typedef ioport_t (p:IOPort) = int (IOPort2int p)

datasort Pin = Pin of (IOPort, int)

typedef pin_t (p:IOPort, n:int) = @(ioport_t p, int n)

// PMR

absview PMR_BIT_V (Pin, bit)

stadef PMR_BIT_IOPORT     = O
stadef PMR_BIT_PERIPHERAL = I

dataview PMR_V (IOPort,bits) =
   {p:IOPort}{b7,b6,b5,b4,b3,b2,b1,b0:bit}
   PMR_V (p, Bits8 (b7,b6,b5,b4,b3,b2,b1,b0)) of
     (PMR_BIT_V (Pin (p,0), b0), PMR_BIT_V (Pin (p,1), b1),
      PMR_BIT_V (Pin (p,2), b2), PMR_BIT_V (Pin (p,3), b3),
      PMR_BIT_V (Pin (p,4), b4), PMR_BIT_V (Pin (p,5), b5),
      PMR_BIT_V (Pin (p,6), b6), PMR_BIT_V (Pin (p,7), b7))

fn {bs,cs:bits}{p:IOPort}
  writePMR (PMR_V (p,bs) | ioport_t p, bits_uint_t (8,cs))
   :(PMR_V (p,cs) | void)

fn {bs,cs:bits}{p:IOPort}{b:bit}
  changePMRBit {bn:int | bn < 8}
    (CHANGE_BIT_BITS (8,bs,bn,b,cs),
     !PMR_V (p,bs) >> PMR_V (p,cs)
    | pin_t (p,bn), bit_uint_t b):void

fn {bs:bits}{p:IOPort}
  readPMR (!PMR_V (p,bs) | p:ioport_t p)
   :bits_uint_t (8,bs)

// PFS関数は延期。PFS_Vのみ定義して、初期値の状態のみ取得できるようにする。
(*
// PWPR

absview PWPR_V (bits)

fn writePWPR {
    pfswe,b0wi,PFSWE,B0WI:bit
    | (pfswe==PFSWE) || (b0wi==O && B0WI==O)
  }(
    !PWPR_V (Bits8 (b0wi,pfswe,O,O,O,O,O,O)) >>
     PWPR_V (Bits8 (B0WI,PFSWE,O,O,O,O,O,O)) |
     bits8int_t (B0WI,PFSWE,O,O,O,O,O,O)
  ):void

fn {pfswe,b0wi:bit}
  readPWPR (!PWPR_V (Bits8 (b0wi,pfswe,O,O,O,O,O,O)))
   :bits8int_t (b0wi,pfswe,O,O,O,O,O,O)
*)

// PFS

absview PFS_V (Pin,bits)
(*
fn {p:IOPort}{pnum:int}
   {b0wi,asel,isel,psel4,psel3,psel2,psel1,psel0:bit}
  writePFS (
    !PWPR_V (Bits8 (O,O,O,O,O,O,I,b0wi)),
    !PFS_V (Pin (p,pnum),Bits8 (asel,isel,O,psel4,psel3,psel2,psel1,psel0)) >>
     PFS_V (Pin (p,pnum),Bits8 (O,O,O,O,O,O,O,O)),
    !PMR_BIT_V (Pin (p,pnum), O)
  | pin_t (p,pnum),
    bits8int_t (O,O,O,O,O,O,O,O)
  )
  :void

fn {p:IOPort}{pnum:int}{asel,isel,psel4,psel3,psel2,psel1,psel0:bit}
  readPFS (
    !PFS_V (Pin (p,pnum),Bits8 (asel,isel,O,psel4,psel3,psel2,psel1,psel0))
  | pin_t (p, pnum)
  )
  :bits8int_t (asel,isel,O,psel4,psel3,psel2,psel1,psel0)
*)

// TODO 周辺機器の重複禁止ビュー
//      最初に機器割り当て端子なしの観を発行する。
//       端子ごとの書き込み許可/禁止のpropが必要。

// PDR

stadef PDR_BIT_WRITABLE  = I
stadef PDR_BIT_READ_ONLY = O

absview PDR_BIT_V (Pin, bit)
dataview PDR_V (IOPort,bits) =
  {p:IOPort}{b7,b6,b5,b4,b3,b2,b1,b0:bit}
  PDR_V (p, Bits8 (b0,b1,b2,b3,b4,b5,b6,b7)) of
            (PDR_BIT_V (Pin (p,0),b0), PDR_BIT_V (Pin (p,1),b1),
             PDR_BIT_V (Pin (p,2),b2), PDR_BIT_V (Pin (p,3),b3),
             PDR_BIT_V (Pin (p,4),b4), PDR_BIT_V (Pin (p,5),b5),
             PDR_BIT_V (Pin (p,6),b6), PDR_BIT_V (Pin (p,7),b7))

absprop PDR_PERMISSION (IOPort,bit_permissions)

dataprop PDR_PERMIT (IOPort,bits) =
 | {p:IOPort}{perms:bit_permissions}{bs:bits}{v:int}
   PDR_PERMIT (p,bs)
    of (PDR_PERMISSION (p,perms),BITS_PERMIT_CERTIFICATE (8,perms,bs))

fn {p:IOPort}{bs,cs:bits}{v: int}
  writePDR (PDR_PERMIT (p,cs),
            !PDR_V (p,bs) >> PDR_V (p,cs) |
            ioport_t p,bits_uint_t (8,cs)):void

fn {p:IOPort}{bs:bits}
  readPDR (!PDR_V (p,bs) | ioport_t p)
   : bits_uint_t (8,bs)

// PODR

stadef PODR_BIT_HIGH   = I
stadef PODR_BIT_GROUND = O

absview PODR_BIT_V (Pin,bit)
dataview PODR_V (IOPort,bits) =
  {p:IOPort}{b7,b6,b5,b4,b3,b2,b1,b0:bit}
  PODR_V (p,Bits8 (b0,b1,b2,b3,b4,b5,b6,b7)) of
            (PODR_BIT_V (Pin (p,0),b0), PODR_BIT_V (Pin (p,1),b1),
             PODR_BIT_V (Pin (p,2),b2), PODR_BIT_V (Pin (p,3),b3),
             PODR_BIT_V (Pin (p,4),b4), PODR_BIT_V (Pin (p,5),b5),
             PODR_BIT_V (Pin (p,6),b6), PODR_BIT_V (Pin (p,7),b7))

absprop PODR_PERMISSION (IOPort,bit_permissions)

dataprop PODR_PERMIT (IOPort,bits) =
 | {p:IOPort}{perms:bit_permissions}{bs:bits}{v:int}
   PODR_PERMIT (p,bs)
    of (PODR_PERMISSION (p,perms),BITS_PERMIT_CERTIFICATE (8,perms,bs))

fn {p:IOPort}{bs,cs:bits}
  writePODR (PODR_PERMIT (p,cs),
             !PODR_V (p,bs) >> PODR_V (p,cs) |
             ioport_t p, bits_uint_t (8,cs)):void

fn {p:IOPort}{bs:bits}
  readPODR (PODR_V (p,bs) | ioport_t p)
   :bits_uint_t (8,bs)

// GPIO

viewdef GPIOView (p:Pin,writable:bit,out:bit) =
  (PMR_BIT_V (p, O), PDR_BIT_V (p, writable), PODR_BIT_V (p, out))

stadef P0 (n:int):Pin = Pin (Port0,n)
stadef P1 (n:int):Pin = Pin (Port1,n)
stadef P2 (n:int):Pin = Pin (Port2,n)
stadef P3 (n:int):Pin = Pin (Port3,n)
stadef P4 (n:int):Pin = Pin (Port4,n)
stadef P5 (n:int):Pin = Pin (Port5,n)
stadef P6 (n:int):Pin = Pin (Port6,n)
stadef P7 (n:int):Pin = Pin (Port7,n)
stadef P8 (n:int):Pin = Pin (Port8,n)
stadef P9 (n:int):Pin = Pin (Port9,n)
stadef PA (n:int):Pin = Pin (PortA,n)
stadef PB (n:int):Pin = Pin (PortB,n)
stadef PC (n:int):Pin = Pin (PortC,n)
stadef PD (n:int):Pin = Pin (PortD,n)
stadef PE (n:int):Pin = Pin (PortE,n)
stadef PF (n:int):Pin = Pin (PortF,n)
stadef PG (n:int):Pin = Pin (PortG,n)
stadef PH (n:int):Pin = Pin (PortH,n)
stadef PI (n:int):Pin = Pin (PortI,n)
stadef PJ (n:int):Pin = Pin (PortJ,n)

// TODO 出力電圧やオープンドレインなどの設定を表す観を作る。
// TODO linタグを復活させる。
(*
fn getInitialPinViews () : //<lin>
    (GPIOView (P0 0,O,I),
     GPIOView (P0 1,I,O),
     GPIOView (P1 0,O,O),
     GPIOView (P1 1,I,I)
     | void)
*)

fn {p:IOPort}{n:int}{rw,outv,before_rw:bit} configIOPin
   (!GPIOView (Pin (p,n),before_rw,outv) >> GPIOView (Pin (p,n),rw,outv)
   | pin:pin_t (p,n), rw:bit_uint_t rw)
   : void

fn {p:IOPort}{n:int}{outv,before_out:bit} putIO
   (!GPIOView (Pin (p,n),I,before_out) >> GPIOView (Pin (p,n),I,outv)
   | pin:pin_t (p,n), bit_uint_t outv)
   : void

fn {p:IOPort}{n:int}{rw,outv:bit} readIO
   (!GPIOView (Pin (p,n),rw,outv) | pin:pin_t (p,n))
   : bit_uint_t outv

(*
 起動からの出力履歴を型に含ませる。
  後から含ませることはできる？
   別のスタンプ化した型を作って、関係する関数に型を追加すれば良い？
    それでも手間が多い？
     すべてのPinViewに追加するよりはマシ？
   追加するには、起動からの時間を管理する仕組みが必要
    取り敢えず面倒くさいから諦める。
  周辺機器に設定すると履歴が取れなくなる？
   周辺機器に設定したことを履歴に残しておけば良い。
*)

// TODO パッケージ毎の差異に対応するための初期absprop
////
fn rx110_64pins_initial_views ():<lin> (
    PODR_PERMISSION (Port0,BitPermissions8 (Permit,Permit,Permit,Permit,Permit,Permit,Permit,Permit)),
    PODR_V          (Port0,Bits8(O,O,O,O,O,O,O,O)),

)

//
// 実装
//


Updating: very minorly

Updating: very minorly

(*
##
## ATS-extsolve-smt2:
## Outputing ATS-constraints
## in the format of smt-lib2
##
*)

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

(*
//
** Author: Hongwei Xi
** Authoremail: gmhwxiATgmailDOTcom
** Start time: June, 2016
//
** Author: William Blair
** Authoremail: wdblairATgmailDOTcom
** Start time: Some time in 2015
//
*)

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
STDIO = "libc/SATS/stdio.sats"
//
(* ****** ****** *)
//
#define
PATSOLVE_targetloc "./.ATS-extsolve"
//
staload "{$PATSOLVE}/patsolve_cnstrnt.sats"
staload "{$PATSOLVE}/patsolve_parsing.sats"
//
(* ****** ****** *)

staload "./patsolve_smt2_commarg.sats"
staload "./patsolve_smt2_solving.sats"

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

implement
fprint_commarg(out, ca) = (
//
case+ ca of
//
| CAhelp(str) =>
    fprint! (out, "CAhelp(", str, ")")
//
| CAgitem(str) =>
    fprint! (out, "CAgitem(", str, ")")
//
| CAinput(str) =>
    fprint! (out, "CAinput(", str, ")")
//
| CAoutput(knd, str) =>
    fprint! (out, "CAoutput(", knd, ", ", str, ")")
//
| CAprintln(str) =>
    fprint! (out, "CAprintln(", str, ")")
| CAprintfile(str) =>
    fprint! (out, "CAprintfile(", str, ")")
//
| CAargend((*void*)) => fprint! (out, "CAargend(", ")")
//
) (* end of [fprint_commarg] *)

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

fun{
} argv_getopt_at
  {n:int}{i:nat}
(
  n: int n, argv: !argv(n), i: int i
) : stropt =
(
//
if i < n
  then stropt_some (argv[i]) else stropt_none ()
// end of [if]
//
) (* end of [argv_getopt_at] *)

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

implement
patsolve_smt2_cmdline
  (argc, argv) = let
//
vtypedef
res_vt = commarglst_vt
//
fun
aux
{n:int}
{i:nat | i <= n}
(
  argc: int n
, argv: !argv(n)
, i: int i, res0: res_vt
) : res_vt = let
in
//
if
i < argc
then let
//
val arg = argv[i]
//
in
//
case+ arg of
//
| "-h" => let
    val ca =
      CAhelp(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux(argc, argv, i+1, res0)
  end // end of ...
| "--help" => let
    val ca =
      CAhelp(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux(argc, argv, i+1, res0)
  end // end of ...
//
| "-i" => let
    val ca =
      CAinput(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
| "--input" => let
    val ca =
      CAinput(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
//
| "-o" => let
    val ca =
      CAoutput(0, arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
| "--output" => let
    val ca =
      CAoutput(0, arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
| "--output-w" => let
    val ca =
      CAoutput(1, arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
| "--output-a" => let
    val ca =
      CAoutput(2, arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
//
| "--println" => let
    val ca =
      CAprintln(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
//
| "--printfile" => let
    val ca =
      CAprintfile(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
//
| _ (*rest*) => let
    val ca =
      CAgitem(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux(argc, argv, i+1, res0)
  end // end of [...]
//
end // end of [then]
else res0 // end of [else]
//
end // end of [aux]
//
and
aux2
{n:int}
{i:nat | i <= n}
(
  argc: int n
, argv: !argv(n)
, i: int i, res0: res_vt
) : res_vt = let
in
if
i < argc
then let
//
val arg = argv[i]
//
val ca =
  CAgitem(arg)
val res0 =
  cons_vt(ca, res0)
// end of [val]
in
  aux(argc, argv, i+1, res0)
end // end of [then]
else res0 // end of [else]
//
end // end of [aux2]
//
val args = aux(argc, argv, 0, nil_vt)
//
in
//
list_vt_reverse(list_vt_cons(CAargend(), args))
//
end // end of [patsolve_smt2_cmdline]

(* ****** ****** *)
//
extern fun patsolve_smt2_help(): void
//
extern fun patsolve_smt2_gitem(string): void
//
extern fun patsolve_smt2_input((*void*)): void
extern fun patsolve_smt2_input_arg(string): void
//
extern fun patsolve_smt2_output(knd: int): void
extern fun patsolve_smt2_output_arg(string): void
//
extern fun patsolve_smt2_println(): void
extern fun patsolve_smt2_printfile(): void
extern fun patsolve_smt2_printfile_arg(string): void
//
extern fun patsolve_smt2_argend((*void*)): void
//
extern fun patsolve_smt2_commarglst_finalize(): void
//
(* ****** ****** *)

typedef
state_struct =
@{
//
  nerr= int
//
, input= int
//
, ninput= int
//
, inpfil_ref= FILEref
//
, output= int
//
, fopen_out= int
, outfil_ref= FILEref
, outfil_mod= file_mode
//
, println= int
, printfile= int
//
, constraint_real= int
//
} (* end of [state_struct] *)

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

local
//
var
the_state: state_struct?
//
val () = the_state.nerr := 0
//
val () = the_state.input := 0
val () = the_state.ninput := 0
//
val () = the_state.inpfil_ref := stdin_ref
//
val () = the_state.output := 0
//
val () = the_state.fopen_out := 0
val () = the_state.outfil_ref := stdout_ref
val () = the_state.outfil_mod := file_mode_w
//
val () = the_state.println := 0
val () = the_state.printfile := 0
//
val () = the_state.constraint_real := 0
//
in (* in-of-local *)
//
val
the_state
  : ref(state_struct) =
  ref_make_viewptr(view@the_state | addr@the_state)
//
end // end of [local]

(* ****** ****** *)
//
implement
the_constraint_real
  ((*void*)) = !the_state.constraint_real
//
(* ****** ****** *)

fun
process_arg
  (x: commarg): void = let
//
(*
val () =
fprintln!
(
  stdout_ref
, "patsolve_smt2_commarglst: process_arg: x = ", x
) (* end of [val] *)
*)
//
in
//
case+ x of
//
| CAhelp _ => patsolve_smt2_help()
//
| CAgitem
    (str) => patsolve_smt2_gitem(str)
  // CAgitem
//
| CAinput _ => patsolve_smt2_input()
//
| CAoutput
    (knd, _) => patsolve_smt2_output(knd)
  // CAoutput
//
| CAprintln _ => patsolve_smt2_println()
| CAprintfile _ => patsolve_smt2_printfile()
//
| CAargend((*void*)) => patsolve_smt2_argend()
//
end // end of [process_arg]

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

implement
patsolve_smt2_commarglst
  (xs) = let
(*
val () = println! ("patsolve_smt2_commarglst")
*)
in
//
case+ xs of
| ~list_vt_cons
    (x, xs) => let
    val () = process_arg(x)
  in
    patsolve_smt2_commarglst (xs)
  end // end of [list_vt_cons]
//
| ~list_vt_nil
    ((*void*)) => patsolve_smt2_commarglst_finalize ()
  // end of [list_vt_nil]
//
end // end of [patsolve_smt2_commarglst]

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

implement
patsolve_smt2_help() = let
//
val out = stdout_ref
val cmdname = "patsolve_smt2"
//
in
//
fprintln!
  (out, "Usage: ", cmdname, " <command> ... <command>\n");
fprintln!
  (out, "where a <command> is of one of the following forms:\n");
//
fprintln! (out, "  -h (for printing out this help usage)");
fprintln! (out, "  -i <filename> (input from <filename>)");
fprintln! (out, "  -o <filename> (output into <filename>)");
//
fprintln! (out);
//
fprintln! (out, "  --help (for printing out this help usage)");
//
fprintln! (out, "  --input <filename> (input from <filename>)");
//
fprintln! (out, "  --output <filename> (output into <filename>)");
fprintln! (out, "  --output-w <filename> (output-write into <filename>)");
fprintln! (out, "  --output-a <filename> (output-append into <filename>)");
//
fprintln! (out, "  --println <string> (print <string>+newline)");
fprintln! (out, "  --printfile <filename> (print the content of <filename>)");
//
fprintln! (out);
//
end (* end of [patsolve_smt2_help] *)

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

implement
patsolve_smt2_input() =
{
//
(*
val () =
println!
  ("patsolve_smt2_input: ...")
*)
//
val () = !the_state.input := 1
val () = !the_state.println := 0
val () = !the_state.printfile := 0
//
} (* end of [patsolve_smt2_input] *)

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

implement
patsolve_smt2_output
  (knd) =
{
//
(*
val () =
println!
  ("patsolve_smt2_output: ...")
*)
//
val () = !the_state.input := 0
val () = !the_state.output := 1
val () = !the_state.println := 0
val () = !the_state.printfile := 0
//
val () =
(
  ifcase
    | knd = 1 => !the_state.outfil_mod := file_mode_w
    | knd = 2 => !the_state.outfil_mod := file_mode_a
    | _(* else *) => ()
) : void // end of [val]
//
} (* end of [patsolve_smt2_output] *)

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

implement
patsolve_smt2_println
  ((*void*)) =
{
//
(*
val () =
println!
  ("patsolve_smt2_print: ...")
*)
//
val () = !the_state.input := 0
val () = !the_state.println := 1
val () = !the_state.printfile := 0
//
} (* end of [patsolve_smt2_print] *)

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

implement
patsolve_smt2_printfile
  ((*void*)) =
{
//
(*
val () =
println!
  ("patsolve_smt2_print: ...")
*)
//
val () = !the_state.input := 0
val () = !the_state.println := 0
val () = !the_state.printfile := 1
//
} (* end of [patsolve_smt2_print] *)

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

implement
patsolve_smt2_gitem(arg) = let
//
(*
val () =
println!
(
  "patsolve_smt2_gitem: arg = ", arg
) (* println! *)
*)
//
macdef
input() = (!the_state.input > 0)
macdef
output() = (!the_state.output > 0)
macdef
println() = (!the_state.println > 0)
macdef
printfile() = (!the_state.printfile > 0)
//
in
//
case+ 0 of
//
| _ when input() =>
  {
    val () = patsolve_smt2_input_arg(arg)
    val () =
    (
      !the_state.ninput := !the_state.ninput+1
    )
  } (* input() *)
| _ when output() =>
  {
    val () = !the_state.output := 0
    val () = patsolve_smt2_output_arg(arg)
  } (* input() *)
//
| _ when println() =>
  {
    val () =
      fprintln! (!the_state.outfil_ref, arg)
    // end of [val]
  } (* input() *)
//
| _ when printfile() =>
  {
    val () = patsolve_smt2_printfile_arg(arg)
  } (* input() *)
//
| _ when
    arg = "--real-on" =>
  {
    val () = !the_state.constraint_real := 1
  }
| _ when
    arg = "--real-off" =>
  {
    val () = !the_state.constraint_real := 0
  }
//
| _ (* unrecognized *) => ((*void*))
//
end (* end of [patsolve_smt2_gitem] *)

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

local

fun
auxmain
  (path: string): void = let
//
val
opt =
fileref_open_opt(path, file_mode_r)
//
in
//
case+ opt of
| ~Some_vt(filr) =>
  {
//
    val c3t0 =
      parse_fileref_constraints(filr)
    // end of [val]
    val ((*void*)) = fileref_close(filr)
//
(*
    val () =
    fprint! (
      stdout_ref
    , "patsolve_smt2_input_arg: c3t0 =\n"
    ) (* end of [fprint] *)
    val () =
      fpprint_c3nstr(stdout_ref, c3t0)
    // end of [val]
    val () = fprint_newline (stdout_ref)
*)
//
    val out = !the_state.outfil_ref
    val ((*void*)) = c3nstr_smt2_solve(out, c3t0)
//
  } (* end of [Some_vt] *)
//
| ~None_vt((*void*)) =>
  {
//
(*
    val () = !the_state.inpfil_ref := stdin_ref
*)
//
    val () =
    prerrln!
      ("The file [", path, "] cannot be opened for read!")
    // end of [val]
//
  } (* end of [None_vt] *)
//
end // end of [auxmain]

in (* in-of-local *)
//
implement
patsolve_smt2_input_arg
  (path) =
(
//
case+
path of
| "-" =>
  {
    val inp = stdin_ref
    val out = !the_state.outfil_ref
    val c3t0 = parse_fileref_constraints(inp)
    val ((*void*)) = c3nstr_smt2_solve(out, c3t0)
  }
| _(* ... *) => auxmain(path)
//
) (* end of [patsolve_smt2_input_arg] *)
//
end // end of [local]

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

implement
patsolve_smt2_output_arg
  (path) = let
//
val n1 = !the_state.fopen_out
val f1 = !the_state.outfil_ref
val () = if n1 > 0 then fileref_close(f1)
//
val fm = !the_state.outfil_mod
val opt = fileref_open_opt(path, fm)
//
in
//
case+ opt of
| ~Some_vt(filr) =>
  {
//
    val () = !the_state.fopen_out := 1
    val () = !the_state.outfil_ref := filr
//
  } (* end of [Some_vt] *)
//
| ~None_vt((*void*)) =>
  {
//
    val () = !the_state.fopen_out := 0
    val () = !the_state.outfil_ref := stderr_ref
//
    val () =
    prerrln!
      ("The file [", path, "] cannot be opened for write!")
    // end of [val]
//
  } (* end of [None_vt] *)
//
end // end of [patsolve_smt2_output_arg]

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

implement
patsolve_smt2_printfile_arg
  (path) = let
//
val fm = file_mode_r
val opt =
  fileref_open_opt(path, fm)
//
val out = !the_state.outfil_ref
//
fun
fcopy
(
  inp: FILEref, out: FILEref
) : void = let
//
val iseof = fileref_is_eof(inp)
//
in
//
if
iseof
then
  fileref_close(inp)
else let
//
val str =
  fileref_get_line_string(inp)
// end of [va]
val ((*void*)) = fprintln! (out, str)
val ((*freed*)) = strptr_free(str)
//
in
  fcopy(inp, out)
end (* end of [else] *)
//
end // end of [fcopy]
//
in
//
case+ opt of
| ~Some_vt(inp) =>
    fcopy(inp, out)
  // end of [Some_vt]
| ~None_vt((*void*)) =>
  (
    fprintln! (out, "(the-file-[", path, "]-cannot-open-for-read)")
  ) (* end of [None_vt] *)
//
end // end of [patsolve_smt2_printfile_arg]

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

implement
patsolve_smt2_argend
  ((*void*)) = let
//
macdef test() =
  (!the_state.input > 0 && !the_state.ninput = 0)
//
in
//
case+ 0 of
| _ when test() =>
  {
//
    val inp = stdin_ref
    val out = !the_state.outfil_ref
    val c3t0 = parse_fileref_constraints(inp)
    val ((*void*)) = c3nstr_smt2_solve(out, c3t0)
//
  } (* end of [test] *)
| _ (*rest*) => ((*ignored*))
//
end (* end of [patsolve_smt2_argend] *)

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

implement
patsolve_smt2_commarglst_finalize
  ((*void*)) =
{
//
  val n1 = !the_state.fopen_out
  val f1 = !the_state.outfil_ref
  val () = if n1 > 0 then fileref_close(f1)
//
} (* end of [patsolve_smt2_commarglst_finalize] *)

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

(* end of [patsolve_smt2_commarg.dats] *)

(*
##
## ATS-extsolve-smt2:
## Outputing ATS-constraints
## in the format of smt-lib2
##
*)

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

(*
//
** Author: Hongwei Xi
** Authoremail: gmhwxiATgmailDOTcom
** Start time: June, 2016
//
** Author: William Blair
** Authoremail: wdblairATgmailDOTcom
** Start time: Some time in 2015
//
*)

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
STDIO = "libc/SATS/stdio.sats"
//
(* ****** ****** *)
//
#define
PATSOLVE_targetloc "./.ATS-extsolve"
//
staload "{$PATSOLVE}/patsolve_cnstrnt.sats"
staload "{$PATSOLVE}/patsolve_parsing.sats"
//
(* ****** ****** *)

staload "./patsolve_smt2_commarg.sats"
staload "./patsolve_smt2_solving.sats"

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

implement
fprint_commarg(out, ca) = (
//
case+ ca of
//
| CAhelp(str) =>
    fprint! (out, "CAhelp(", str, ")")
//
| CAgitem(str) =>
    fprint! (out, "CAgitem(", str, ")")
//
| CAinput(str) =>
    fprint! (out, "CAinput(", str, ")")
//
| CAoutput(knd, str) =>
    fprint! (out, "CAoutput(", knd, ", ", str, ")")
//
| CAprintln(str) =>
    fprint! (out, "CAprintln(", str, ")")
| CAprintfile(str) =>
    fprint! (out, "CAprintfile(", str, ")")
//
| CAargend((*void*)) => fprint! (out, "CAargend(", ")")
//
) (* end of [fprint_commarg] *)

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

fun{
} argv_getopt_at
  {n:int}{i:nat}
(
  n: int n, argv: !argv(n), i: int i
) : stropt =
(
//
if i < n
  then stropt_some (argv[i]) else stropt_none ()
// end of [if]
//
) (* end of [argv_getopt_at] *)

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

implement
patsolve_smt2_cmdline
  (argc, argv) = let
//
vtypedef
res_vt = commarglst_vt
//
fun
aux
{n:int}
{i:nat | i <= n}
(
  argc: int n
, argv: !argv(n)
, i: int i, res0: res_vt
) : res_vt = let
in
//
if
i < argc
then let
//
val arg = argv[i]
//
in
//
case+ arg of
//
| "-h" => let
    val ca =
      CAhelp(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux(argc, argv, i+1, res0)
  end // end of ...
| "--help" => let
    val ca =
      CAhelp(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux(argc, argv, i+1, res0)
  end // end of ...
//
| "-i" => let
    val ca =
      CAinput(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
| "--input" => let
    val ca =
      CAinput(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
//
| "-o" => let
    val ca =
      CAoutput(0, arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
| "--output" => let
    val ca =
      CAoutput(0, arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
| "--output-w" => let
    val ca =
      CAoutput(1, arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
| "--output-a" => let
    val ca =
      CAoutput(2, arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
//
| "--println" => let
    val ca =
      CAprintln(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
//
| "--printfile" => let
    val ca =
      CAprintfile(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux2(argc, argv, i+1, res0)
  end // end of ...
//
| _ (*rest*) => let
    val ca =
      CAgitem(arg)
    val res0 =
      cons_vt(ca, res0)
    // end of [val]
  in
    aux(argc, argv, i+1, res0)
  end // end of [...]
//
end // end of [then]
else res0 // end of [else]
//
end // end of [aux]
//
and
aux2
{n:int}
{i:nat | i <= n}
(
  argc: int n
, argv: !argv(n)
, i: int i, res0: res_vt
) : res_vt = let
in
if
i < argc
then let
//
val arg = argv[i]
//
val ca =
  CAgitem(arg)
val res0 =
  cons_vt(ca, res0)
// end of [val]
in
  aux(argc, argv, i+1, res0)
end // end of [then]
else res0 // end of [else]
//
end // end of [aux2]
//
val args = aux(argc, argv, 0, nil_vt)
//
in
//
list_vt_reverse(list_vt_cons(CAargend(), args))
//
end // end of [patsolve_smt2_cmdline]

(* ****** ****** *)
//
extern fun patsolve_smt2_help(): void
//
extern fun patsolve_smt2_gitem(string): void
//
extern fun patsolve_smt2_input((*void*)): void
extern fun patsolve_smt2_input_arg(string): void
//
extern fun patsolve_smt2_output(knd: int): void
extern fun patsolve_smt2_output_arg(string): void
//
extern fun patsolve_smt2_println(): void
extern fun patsolve_smt2_printfile(): void
extern fun patsolve_smt2_printfile_arg(string): void
//
extern fun patsolve_smt2_argend((*void*)): void
//
extern fun patsolve_smt2_commarglst_finalize(): void
//
(* ****** ****** *)

typedef
state_struct =
@{
//
  nerr= int
//
, input= int
//
, ninput= int
//
, inpfil_ref= FILEref
//
, output= int
//
, fopen_out= int
, outfil_ref= FILEref
, outfil_mod= file_mode
//
, println= int
, printfile= int
//
, constraint_real= int
//
} (* end of [state_struct] *)

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

local
//
var
the_state: state_struct?
//
val () = the_state.nerr := 0
//
val () = the_state.input := 0
val () = the_state.ninput := 0
//
val () = the_state.inpfil_ref := stdin_ref
//
val () = the_state.output := 0
//
val () = the_state.fopen_out := 0
val () = the_state.outfil_ref := stdout_ref
val () = the_state.outfil_mod := file_mode_w
//
val () = the_state.println := 0
val () = the_state.printfile := 0
//
val () = the_state.constraint_real := 0
//
in (* in-of-local *)
//
val
the_state
  : ref(state_struct) =
  ref_make_viewptr(view@the_state | addr@the_state)
//
end // end of [local]

(* ****** ****** *)
//
implement
the_constraint_real
  ((*void*)) = !the_state.constraint_real
//
(* ****** ****** *)

fun
process_arg
  (x: commarg): void = let
//
(*
val () =
fprintln!
(
  stdout_ref
, "patsolve_smt2_commarglst: process_arg: x = ", x
) (* end of [val] *)
*)
//
in
//
case+ x of
//
| CAhelp _ => patsolve_smt2_help()
//
| CAgitem
    (str) => patsolve_smt2_gitem(str)
  // CAgitem
//
| CAinput _ => patsolve_smt2_input()
//
| CAoutput
    (knd, _) => patsolve_smt2_output(knd)
  // CAoutput
//
| CAprintln _ => patsolve_smt2_println()
| CAprintfile _ => patsolve_smt2_printfile()
//
| CAargend((*void*)) => patsolve_smt2_argend()
//
end // end of [process_arg]

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

implement
patsolve_smt2_commarglst
  (xs) = let
(*
val () = println! ("patsolve_smt2_commarglst")
*)
in
//
case+ xs of
| ~list_vt_cons
    (x, xs) => let
    val () = process_arg(x)
  in
    patsolve_smt2_commarglst (xs)
  end // end of [list_vt_cons]
//
| ~list_vt_nil
    ((*void*)) => patsolve_smt2_commarglst_finalize ()
  // end of [list_vt_nil]
//
end // end of [patsolve_smt2_commarglst]

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

implement
patsolve_smt2_help() = let
//
val out = stdout_ref
val cmdname = "patsolve_smt2"
//
in
//
fprintln!
  (out, "Usage: ", cmdname, " <command> ... <command>\n");
fprintln!
  (out, "where a <command> is of one of the following forms:\n");
//
fprintln! (out, "  -h (for printing out this help usage)");
fprintln! (out, "  -i <filename> (input from <filename>)");
fprintln! (out, "  -o <filename> (output into <filename>)");
//
fprintln! (out);
//
fprintln! (out, "  --help (for printing out this help usage)");
//
fprintln! (out, "  --print <string> (print <string>+newline)");
//
fprintln! (out, "  --input <filename> (input from <filename>)");
//
fprintln! (out, "  --output <filename> (output into <filename>)");
fprintln! (out, "  --output-w <filename> (output-write into <filename>)");
fprintln! (out, "  --output-a <filename> (output-append into <filename>)");
//
fprintln! (out);
//
end (* end of [patsolve_smt2_help] *)

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

implement
patsolve_smt2_input() =
{
//
(*
val () =
println!
  ("patsolve_smt2_input: ...")
*)
//
val () = !the_state.input := 1
val () = !the_state.println := 0
val () = !the_state.printfile := 0
//
} (* end of [patsolve_smt2_input] *)

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

implement
patsolve_smt2_output
  (knd) =
{
//
(*
val () =
println!
  ("patsolve_smt2_output: ...")
*)
//
val () = !the_state.input := 0
val () = !the_state.output := 1
val () = !the_state.println := 0
val () = !the_state.printfile := 0
//
val () =
(
  ifcase
    | knd = 1 => !the_state.outfil_mod := file_mode_w
    | knd = 2 => !the_state.outfil_mod := file_mode_a
    | _(* else *) => ()
) : void // end of [val]
//
} (* end of [patsolve_smt2_output] *)

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

implement
patsolve_smt2_println
  ((*void*)) =
{
//
(*
val () =
println!
  ("patsolve_smt2_print: ...")
*)
//
val () = !the_state.input := 0
val () = !the_state.println := 1
val () = !the_state.printfile := 0
//
} (* end of [patsolve_smt2_print] *)

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

implement
patsolve_smt2_printfile
  ((*void*)) =
{
//
(*
val () =
println!
  ("patsolve_smt2_print: ...")
*)
//
val () = !the_state.input := 0
val () = !the_state.println := 0
val () = !the_state.printfile := 1
//
} (* end of [patsolve_smt2_print] *)

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

implement
patsolve_smt2_gitem(arg) = let
//
(*
val () =
println!
(
  "patsolve_smt2_gitem: arg = ", arg
) (* println! *)
*)
//
macdef
input() = (!the_state.input > 0)
macdef
output() = (!the_state.output > 0)
macdef
println() = (!the_state.println > 0)
macdef
printfile() = (!the_state.printfile > 0)
//
in
//
case+ 0 of
//
| _ when input() =>
  {
    val () = patsolve_smt2_input_arg(arg)
    val () =
    (
      !the_state.ninput := !the_state.ninput+1
    )
  } (* input() *)
| _ when output() =>
  {
    val () = !the_state.output := 0
    val () = patsolve_smt2_output_arg(arg)
  } (* input() *)
//
| _ when println() =>
  {
    val () =
      fprintln! (!the_state.outfil_ref, arg)
    // end of [val]
  } (* input() *)
//
| _ when printfile() =>
  {
    val () = patsolve_smt2_printfile_arg(arg)
  } (* input() *)
//
| _ when
    arg = "--real-on" =>
  {
    val () = !the_state.constraint_real := 1
  }
| _ when
    arg = "--real-off" =>
  {
    val () = !the_state.constraint_real := 0
  }
//
| _ (* unrecognized *) => ((*void*))
//
end (* end of [patsolve_smt2_gitem] *)

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

local

fun
auxmain
  (path: string): void = let
//
val
opt =
fileref_open_opt(path, file_mode_r)
//
in
//
case+ opt of
| ~Some_vt(filr) =>
  {
//
    val c3t0 =
      parse_fileref_constraints(filr)
    // end of [val]
    val ((*void*)) = fileref_close(filr)
//
(*
    val () =
    fprint! (
      stdout_ref
    , "patsolve_smt2_input_arg: c3t0 =\n"
    ) (* end of [fprint] *)
    val () =
      fpprint_c3nstr(stdout_ref, c3t0)
    // end of [val]
    val () = fprint_newline (stdout_ref)
*)
//
    val out = !the_state.outfil_ref
    val ((*void*)) = c3nstr_smt2_solve(out, c3t0)
//
  } (* end of [Some_vt] *)
//
| ~None_vt((*void*)) =>
  {
//
(*
    val () = !the_state.inpfil_ref := stdin_ref
*)
//
    val () =
    prerrln!
      ("The file [", path, "] cannot be opened for read!")
    // end of [val]
//
  } (* end of [None_vt] *)
//
end // end of [auxmain]

in (* in-of-local *)
//
implement
patsolve_smt2_input_arg
  (path) =
(
//
case+
path of
| "-" =>
  {
    val inp = stdin_ref
    val out = !the_state.outfil_ref
    val c3t0 = parse_fileref_constraints(inp)
    val ((*void*)) = c3nstr_smt2_solve(out, c3t0)
  }
| _(* ... *) => auxmain(path)
//
) (* end of [patsolve_smt2_input_arg] *)
//
end // end of [local]

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

implement
patsolve_smt2_output_arg
  (path) = let
//
val n1 = !the_state.fopen_out
val f1 = !the_state.outfil_ref
val () = if n1 > 0 then fileref_close(f1)
//
val fm = !the_state.outfil_mod
val opt = fileref_open_opt(path, fm)
//
in
//
case+ opt of
| ~Some_vt(filr) =>
  {
//
    val () = !the_state.fopen_out := 1
    val () = !the_state.outfil_ref := filr
//
  } (* end of [Some_vt] *)
//
| ~None_vt((*void*)) =>
  {
//
    val () = !the_state.fopen_out := 0
    val () = !the_state.outfil_ref := stderr_ref
//
    val () =
    prerrln!
      ("The file [", path, "] cannot be opened for write!")
    // end of [val]
//
  } (* end of [None_vt] *)
//
end // end of [patsolve_smt2_output_arg]

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

implement
patsolve_smt2_printfile_arg
  (path) = let
//
val fm = file_mode_r
val opt =
  fileref_open_opt(path, fm)
//
val out = !the_state.outfil_ref
//
fun
fcopy
(
  inp: FILEref, out: FILEref
) : void = let
//
val iseof = fileref_is_eof(inp)
//
in
//
if
iseof
then
  fileref_close(inp)
else let
//
val str =
  fileref_get_line_string(inp)
// end of [va]
val ((*void*)) = fprintln! (out, str)
val ((*freed*)) = strptr_free(str)
//
in
  fcopy(inp, out)
end (* end of [else] *)
//
end // end of [fcopy]
//
in
//
case+ opt of
| ~Some_vt(inp) =>
    fcopy(inp, out)
  // end of [Some_vt]
| ~None_vt((*void*)) =>
  (
    fprintln! (out, "(the-file-[", path, "]-cannot-open-for-read)")
  ) (* end of [None_vt] *)
//
end // end of [patsolve_smt2_printfile_arg]

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

implement
patsolve_smt2_argend
  ((*void*)) = let
//
macdef test() =
  (!the_state.input > 0 && !the_state.ninput = 0)
//
in
//
case+ 0 of
| _ when test() =>
  {
//
    val inp = stdin_ref
    val out = !the_state.outfil_ref
    val c3t0 = parse_fileref_constraints(inp)
    val ((*void*)) = c3nstr_smt2_solve(out, c3t0)
//
  } (* end of [test] *)
| _ (*rest*) => ((*ignored*))
//
end (* end of [patsolve_smt2_argend] *)

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

implement
patsolve_smt2_commarglst_finalize
  ((*void*)) =
{
//
  val n1 = !the_state.fopen_out
  val f1 = !the_state.outfil_ref
  val () = if n1 > 0 then fileref_close(f1)
//
} (* end of [patsolve_smt2_commarglst_finalize] *)

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

(* end of [patsolve_smt2_commarg.dats] *)


Use case with new compiler

Use case with new compiler

#include "config.hats"
#include "{$TOP}/avr_prelude/kernel_staload.hats"

staload "{$TOP}/SATS/arduino.sats"
staload UN = "prelude/SATS/unsafe.sats"

#define LED 9
#define BUTTON 7
#define DELAY_MS 10.0

typedef state_dat = @{ state= natLt(2), brightness= natLt(256), start_time= ulint }
#define STATE_LEDOFF 0
#define STATE_LEDON  1

fun state_transition (sd:state_dat):state_dat = @{ state= state, brightness= br, start_time= start } where {
  val state = case+ sd.state of
              | STATE_LEDOFF => STATE_LEDON
              | STATE_LEDON  => STATE_LEDOFF
  val br = sd.brightness
  val start = millis ()
}

fun state_helddown (sd:state_dat):state_dat = @{ state= state, brightness= br, start_time= start } where {
  val state = sd.state
  val start = sd.start_time
  val t = if (state = STATE_LEDON) && (millis () - sd.start_time > $UN.cast 500)
            then sd.brightness + 1
            else sd.brightness
  val br = if gt_g0int_int (t, 255) then 0 else $UN.cast t
}

fun do_state (b: natLt(2), old_b:natLt(2), sd:state_dat): state_dat =
  case+ (b, old_b) of
  | (HIGH, LOW)  => state_transition sd
  | (HIGH, HIGH) => state_helddown sd
  | (_, _) => sd

fun do_action (sd:state_dat): void =
  case+ sd.state of
  | STATE_LEDON  => analogWrite(LED, sd.brightness)
  | STATE_LEDOFF => analogWrite(LED, 0)

implement main () = {
  fun loop (old_b:natLt(2), sd:state_dat) = {
    val b = digitalRead (BUTTON)
    val nsd = do_state (b, old_b, sd)
    val () = delay_ms (DELAY_MS)
    val () = do_action nsd
    val () = loop (b, nsd)
  }
  val () = pinMode (LED, OUTPUT)
  val () = pinMode (BUTTON, INPUT)
  val () = loop (LOW, @{ state= STATE_LEDOFF, brightness= 128, start_time= $UN.cast 0 })
}

#include "config.hats"
#include "{$TOP}/avr_prelude/kernel_staload.hats"

staload "{$TOP}/SATS/arduino.sats"
staload UN = "prelude/SATS/unsafe.sats"

#define LED 9
#define BUTTON 7
#define DELAY_MS 10.0

typedef state_dat = @{ state= natLt(2), brightness= natLt(256), start_time= ulint }
#define STATE_LEDOFF 0
#define STATE_LEDON  1

fun state_transition (sd:state_dat):state_dat = @{ state= state, brightness= br, start_time= start } where {
  val state = case+ sd.state of
              | STATE_LEDOFF => STATE_LEDON
              | STATE_LEDON  => STATE_LEDOFF
  val br = sd.brightness
  val start = millis ()
}

fun state_helddown (sd:state_dat):state_dat = @{ state= state, brightness= br, start_time= start } where {
  val state = sd.state
  val start = sd.start_time
  val t = if (state = STATE_LEDON) && (millis () - sd.start_time > $UN.cast 500)
            then sd.brightness + 1
            else sd.brightness
  val br = if gt_g0int_int (t, 255) then 0 else $UN.cast t
}

fun do_state (b: natLt(2), old_b:natLt(2), sd:state_dat): state_dat =
  if b = HIGH && old_b = LOW then state_transition sd
  else if b = HIGH && old_b = HIGH then state_helddown sd
       else sd

fun do_action (sd:state_dat): void =
  case+ sd.state of
  | STATE_LEDON  => analogWrite(LED, sd.brightness)
  | STATE_LEDOFF => analogWrite(LED, 0)

implement main () = {
  fun loop (old_b:natLt(2), sd:state_dat) = {
    val b = digitalRead (BUTTON)
    val nsd = do_state (b, old_b, sd)
    val () = delay_ms (DELAY_MS)
    val () = do_action nsd
    val () = loop (b, nsd)
  }
  val () = pinMode (LED, OUTPUT)
  val () = pinMode (BUTTON, INPUT)
  val () = loop (LOW, @{ state= STATE_LEDOFF, brightness= 128, start_time= $UN.cast 0 })
}


Updating: very minorly tidying-up

Updating: very minorly tidying-up

(***********************************************************************)
(*                                                                     *)
(*                         ATS/contrib/atshwxi                         *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2014 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
** OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
** THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
** IN THE SOFTWARE.
*)

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

(*
absvt@ype T
#define CAPACITY1 (= CAPACITY + 1)
*)

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

extern fun get_size ():<> size_t
extern fun get_capacity ():<> size_t

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

extern fun is_nil ():<> bool
extern fun isnot_nil ():<> bool
extern fun is_full ():<> bool
extern fun isnot_full ():<> bool

(* ****** ****** *)
//
exception
GDEQARRAYinsert of ()
//
extern
fun
insert_atbeg
(
  x0: T, res: &T? >> opt (T, b)
) : #[b:bool] bool(b) // endfun
//
extern
fun insert_atbeg_exn (x0: T): void
extern
fun insert_atbeg_opt (x0: T): Option_vt (T)
//
extern
fun
insert_atend
(
  x0: T, res: &T? >> opt (T, b)
) : #[b:bool] bool(b) // endfun
//
extern
fun insert_atend_exn (x0: T): void
extern
fun insert_atend_opt (x0: T): Option_vt (T)
//
(* ****** ****** *)
//
exception
GDEQARRAYtakeout of ()
//
extern
fun
takeout_atbeg
(
  x0: &T? >> opt (T, b)
) : #[b:bool] bool (b) // endfun
//
extern
fun takeout_atbeg_exn ((*void*)): T
extern
fun takeout_atbeg_opt ((*void*)): Option_vt (T)
//
extern
fun
takeout_atend
(
  x0: &T? >> opt (T, b)
) : #[b:bool] bool (b) // endfun
//
extern
fun takeout_atend_exn ((*void*)): T
extern
fun takeout_atend_opt ((*void*)): Option_vt (T)
//
(* ****** ****** *)

local
//
staload
UN = "prelude/SATS/unsafe.sats"
//
staload "libats/SATS/deqarray.sats"
staload _ = "libats/DATS/deqarray.dats"
//
#define
CAPACITY (CAPACITY1-1)
//
local
//
var
_array_ =
@[T][CAPACITY1]()
//
in(*in-of-local*)
val
theArrayptr =
$UN.castvwtp0{arrayptr(T?,CAPACITY1)}((view@_array_ | addr@_array_))
end // end of [local]
//
local
val
cap = CAPACITY
var
_struct_
: deqarray_tsize (*uninitized*)
//
in (*in-of-local*)
val
(pfngc|theDQA0) =
deqarray_make_ngc__tsz{T}(view@_struct_ | addr@_struct_, theArrayptr, i2sz(cap), sizeof<T>)
end // end of [local]
//
vtypedef
DQA = [n:nat] deqarray(T, CAPACITY, n)
//
val theDQA0_ptr = $UN.castvwtp0{ptr}((pfngc | theDQA0))
//
in (* in-of-local *)

implement
get_size () = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val res = deqarray_get_size (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [get_size] *)

implement
get_capacity () = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val res = deqarray_get_capacity (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [get_capacity] *)

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

implement
is_nil () = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val res = deqarray_is_nil (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [is_nil] *)

implement
isnot_nil () = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val res = deqarray_isnot_nil (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [isnot_nil] *)

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

implement
is_full () = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val res = deqarray_is_full (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [is_full] *)

implement
isnot_full () = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val res = deqarray_isnot_full (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [isnot_full] *)

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

implement
insert_atbeg
  (x0, res) = let
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val isnot = deqarray_isnot_full (dqa)
//
in
//
if isnot
  then let
    val () = deqarray_insert_atbeg (dqa, x0)
    prval ((*void*)) = opt_none (res)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    false
  end // end of [then]
  else let
    val () = res := x0
    prval ((*void*)) = opt_some (res)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    true
  end // end of [else]
// end of [if]
//
end // end of [insert_atbeg]

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

implement
insert_atbeg_exn(x0) = () where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
//
val ((*void*)) = (
//
if
deqarray_isnot_full (dqa)
then deqarray_insert_atbeg (dqa, x0)
else $raise GDEQARRAYinsert((*void*))
//
) : void // end of [val]
//
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [insert_atbeg_exn] *)

implement
insert_atbeg_opt(x0) = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val res = deqarray_insert_atbeg_opt (dqa, x0)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [insert_atbeg_opt] *)

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

implement
insert_atend
  (x0, res) = let
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val isnot = deqarray_isnot_full (dqa)
//
in
//
if isnot
  then let
    val () = deqarray_insert_atend (dqa, x0)
    prval ((*void*)) = opt_none (res)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    false
  end // end of [then]
  else let
    val () = res := x0
    prval ((*void*)) = opt_some (res)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    true
  end // end of [else]
// end of [if]
//
end // end of [insert_atend]

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

implement
insert_atend_exn(x0) = () where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
//
val ((*void*)) = (
//
if
deqarray_isnot_full (dqa)
then deqarray_insert_atend (dqa, x0)
else $raise GDEQARRAYinsert((*void*))
//
) : void // end of [val]
//
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [insert_atend_exn] *)

implement
insert_atend_opt(x0) = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val res = deqarray_insert_atend_opt (dqa, x0)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [insert_atend_opt] *)

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

implement
takeout_atbeg(x0) = let
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val isnot = deqarray_isnot_nil (dqa)
//
in
//
if isnot
  then let
    val () =
    x0 := deqarray_takeout_atbeg (dqa)
    prval () = opt_some{T}(x0)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    true
  end // end of [then]
  else let
    prval () = opt_none{T}(x0)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    false
  end // end of [else]
// end of [if]
//
end // end of [takeout_atbeg]

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

implement
takeout_atbeg_exn() = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
//
val res = (
//
if
deqarray_isnot_nil(dqa)
then deqarray_takeout_atbeg (dqa)
else $raise GDEQARRAYtakeout((*void*))
//
) : T // end of [val]
//
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [takeout_atbeg_exn] *)

implement
takeout_atbeg_opt() = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val res = deqarray_takeout_atbeg_opt (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [takeout_atbeg_opt] *)

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

implement
takeout_atend(x0) = let
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
val isnot = deqarray_isnot_nil (dqa)
//
in
//
if isnot
  then let
    val () =
    x0 := deqarray_takeout_atend (dqa)
    prval ((*void*)) = opt_some{T}(x0)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    true
  end // end of [then]
  else let
    prval ((*void*)) = opt_none{T}(x0)
    prval ((*void*)) = $UN.cast2void(dqa)
  in
    false
  end // end of [else]
// end of [if]
//
end // end of [takeout_atend]

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

implement
takeout_atend_exn() = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(theDQA0_ptr)
//
val res = (
//
if
deqarray_isnot_nil(dqa)
then deqarray_takeout_atend(dqa)
else $raise GDEQARRAYtakeout((*void*))
//
) : T // end of [val]
//
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [takeout_atend_exn] *)

implement
takeout_atend_opt() = res where
{
//
val dqa =
  $UN.castvwtp0{DQA}(theDQA0_ptr)
//
val res =
  deqarray_takeout_atend_opt (dqa)
//
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [takeout_atend_opt] *)

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

end // end of [local]

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

(* end of [gdeqarray.hats] *)

(***********************************************************************)
(*                                                                     *)
(*                         ATS/contrib/atshwxi                         *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2014 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
** OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
** THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
** IN THE SOFTWARE.
*)

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

(*
absvt@ype T
#define CAPACITY1 (= CAPACITY + 1)
*)

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

extern fun get_size ():<> size_t
extern fun get_capacity ():<> size_t

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

extern fun is_nil ():<> bool
extern fun isnot_nil ():<> bool
extern fun is_full ():<> bool
extern fun isnot_full ():<> bool

(* ****** ****** *)
//
exception
GDEQARRAYinsert of ()
//
extern
fun
insert_atbeg
(
  x0: T, res: &T? >> opt (T, b)
) : #[b:bool] bool(b) // endfun
//
extern
fun insert_atbeg_exn (x0: T): void
extern
fun insert_atbeg_opt (x0: T): Option_vt (T)
//
extern
fun
insert_atend
(
  x0: T, res: &T? >> opt (T, b)
) : #[b:bool] bool(b) // endfun
//
extern
fun insert_atend_exn (x0: T): void
extern
fun insert_atend_opt (x0: T): Option_vt (T)
//
(* ****** ****** *)
//
exception
GDEQARRAYtakeout of ()
//
extern
fun
takeout_atbeg
(
  x0: &T? >> opt (T, b)
) : #[b:bool] bool (b) // endfun
//
extern
fun takeout_atbeg_exn ((*void*)): T
extern
fun takeout_atbeg_opt ((*void*)): Option_vt (T)
//
extern
fun
takeout_atend
(
  x0: &T? >> opt (T, b)
) : #[b:bool] bool (b) // endfun
//
extern
fun takeout_atend_exn ((*void*)): T
extern
fun takeout_atend_opt ((*void*)): Option_vt (T)
//
(* ****** ****** *)

local
//
staload "libats/SATS/deqarray.sats"
staload _ = "libats/DATS/deqarray.dats"
//
staload UN = "prelude/SATS/unsafe.sats"
//
#define
CAPACITY (CAPACITY1-1)
//
local
var _array = @[T][CAPACITY1]()
in (*in-of-local*)
val the_arrayptr =
$UN.castvwtp0{arrayptr(T?,CAPACITY1)}((view@_array | addr@_array))
end // end of [local]
//
local
val cap = CAPACITY
var _struct: deqarray_tsize // uninitized
in (*in-of-local*)
val (pfngc | the_deqarray) =
deqarray_make_ngc__tsz{T}(view@_struct | addr@_struct, the_arrayptr, i2sz(cap), sizeof<T>)
end // end of [local]
//
vtypedef DQA = [n:nat] deqarray(T, CAPACITY, n)
val the_deqarray_ptr = $UN.castvwtp0{ptr}((pfngc | the_deqarray))
//
in (* in-of-local *)

implement
get_size () = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val res = deqarray_get_size (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [get_size] *)

implement
get_capacity () = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val res = deqarray_get_capacity (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [get_capacity] *)

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

implement
is_nil () = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val res = deqarray_is_nil (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [is_nil] *)

implement
isnot_nil () = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val res = deqarray_isnot_nil (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [isnot_nil] *)

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

implement
is_full () = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val res = deqarray_is_full (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [is_full] *)

implement
isnot_full () = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val res = deqarray_isnot_full (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [isnot_full] *)

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

implement
insert_atbeg
  (x0, res) = let
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val isnot = deqarray_isnot_full (dqa)
//
in
//
if isnot
  then let
    val () = deqarray_insert_atbeg (dqa, x0)
    prval ((*void*)) = opt_none (res)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    false
  end // end of [then]
  else let
    val () = res := x0
    prval ((*void*)) = opt_some (res)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    true
  end // end of [else]
// end of [if]
//
end // end of [insert_atbeg]

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

implement
insert_atbeg_exn(x0) = () where
{
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
//
val ((*void*)) = (
//
if
deqarray_isnot_full (dqa)
then deqarray_insert_atbeg (dqa, x0)
else $raise GDEQARRAYinsert((*void*))
//
) : void // end of [val]
//
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [insert_atbeg_exn] *)

implement
insert_atbeg_opt(x0) = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val res = deqarray_insert_atbeg_opt (dqa, x0)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [insert_atbeg_opt] *)

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

implement
insert_atend
  (x0, res) = let
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val isnot = deqarray_isnot_full (dqa)
//
in
//
if isnot
  then let
    val () = deqarray_insert_atend (dqa, x0)
    prval ((*void*)) = opt_none (res)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    false
  end // end of [then]
  else let
    val () = res := x0
    prval ((*void*)) = opt_some (res)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    true
  end // end of [else]
// end of [if]
//
end // end of [insert_atend]

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

implement
insert_atend_exn(x0) = () where
{
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
//
val ((*void*)) = (
//
if
deqarray_isnot_full (dqa)
then deqarray_insert_atend (dqa, x0)
else $raise GDEQARRAYinsert((*void*))
//
) : void // end of [val]
//
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [insert_atend_exn] *)

implement
insert_atend_opt(x0) = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val res = deqarray_insert_atend_opt (dqa, x0)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [insert_atend_opt] *)

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

implement
takeout_atbeg(x0) = let
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val isnot = deqarray_isnot_nil (dqa)
//
in
//
if isnot
  then let
    val () =
    x0 := deqarray_takeout_atbeg (dqa)
    prval () = opt_some{T}(x0)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    true
  end // end of [then]
  else let
    prval () = opt_none{T}(x0)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    false
  end // end of [else]
// end of [if]
//
end // end of [takeout_atbeg]

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

implement
takeout_atbeg_exn() = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
//
val res = (
//
if
deqarray_isnot_nil(dqa)
then deqarray_takeout_atbeg (dqa)
else $raise GDEQARRAYtakeout((*void*))
//
) : T // end of [val]
//
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [takeout_atbeg_exn] *)

implement
takeout_atbeg_opt() = res where
{
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val res = deqarray_takeout_atbeg_opt (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
} (* end of [takeout_atbeg_opt] *)

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

implement
takeout_atend(x0) = let
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
val isnot = deqarray_isnot_nil (dqa)
//
in
//
if isnot
  then let
    val () =
    x0 := deqarray_takeout_atend (dqa)
    prval ((*void*)) = opt_some{T}(x0)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    true
  end // end of [then]
  else let
    prval ((*void*)) = opt_none{T}(x0)
    prval ((*void*)) = $UN.cast2void (dqa)
  in
    false
  end // end of [else]
// end of [if]
//
end // end of [takeout_atend]

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

implement
takeout_atend_exn() = res where
{
//
val dqa =
$UN.castvwtp0{DQA}(the_deqarray_ptr)
//
val res = (
//
if
deqarray_isnot_nil(dqa)
then deqarray_takeout_atend (dqa)
else $raise GDEQARRAYtakeout((*void*))
//
) : T // end of [val]
//
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [takeout_atend_exn] *)

implement
takeout_atend_opt() = res where
{
//
val dqa =
  $UN.castvwtp0{DQA}(the_deqarray_ptr)
//
val res = deqarray_takeout_atend_opt (dqa)
prval ((*void*)) = $UN.cast2void (dqa)
//
} (* end of [takeout_atend_opt] *)

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

end // end of [local]

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

(* end of [gdeqarray.hats] *)


Updating: very minorly improving

Updating: very minorly improving

(* ****** ****** *)
//
// HX-2014-12-25:
// For the purpose of
// studying session types
//
(* ****** ****** *)
//
abstype send (a:vt@ype)
abstype recv (a:vt@ype)
//
(* ****** ****** *)

abstype
chseq (a:type, b:type)

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

stadef nil = unit
stadef :: (a:type, b:type) = chseq (a, b)

(* ****** ****** *)
//
absvtype chpos(type)
absvtype chneg(type)
//
(* ****** ****** *)
//
extern
fun{a:vt0p}
chpos_send{ss:type}
  (ch: !chpos(send(a) :: ss) >> chpos(ss), x: a): void
extern
fun{a:vt0p}
chpos_recv{ss:type}
  (ch: !chpos(recv(a) :: ss) >> chpos(ss), x: &a? >> _): void
extern
fun{a:vt0p}
chpos_recv_val{ss:type}(ch: !chpos(recv(a) :: ss) >> chpos(ss)): a
//
(* ****** ****** *)
//
extern
fun{a:vt0p}
chneg_recv{ss:type}
  (ch: !chneg(recv(a) :: ss) >> chneg(ss), x: a): void
extern
fun{a:vt0p}
chneg_send{ss:type}
  (ch: !chneg(send(a) :: ss) >> chneg(ss), x: &a? >> _): void
extern
fun{a:vt0p}
chneg_send_val{ss:type}(ch: !chneg(send(a) :: ss) >> chneg(ss)): a
//
(* ****** ****** *)

extern
fun chpos_recv_close (ch: chpos(nil)): void
extern
fun chneg_send_close (ch: chneg(nil)): void

(* ****** ****** *)
//
extern
fun
chpos_chneg_connect{ss:type} (ch1: chpos(ss), ch2: chneg(ss)): void
//
(* ****** ****** *)
//
datatype
sslist (a:t@ype) =
| sslist_nil of (nil)
| sslist_cons of (send(a) :: sslist(a))
//
(*
datavtype
chpos_sslist (a:t@ype) =
| chpos_sslist_nil of ()
| chpos_sslist_cons of (chpos(send(a) :: sslist(a)))
*)
//
datavtype
chneg_sslist (a:t@ype) =
| chneg_sslist_nil of ()
| chneg_sslist_cons of (chneg(send(a) :: sslist(a)))
//
(* ****** ****** *)
//
(*
extern
fun
chpos_sslist
  {a:t0p}(chpos(sslist(a))): chpos_sslist(a)
extern
fun
chneg_sslist_nil{a:t0p}(chneg(sslist(a))): void
and
chneg_sslist_cons
  {a:t0p}(chneg(sslist(a))): chneg(send(a) :: sslist(a))
*)
//
(* ****** ****** *)
//
extern
fun
chneg_sslist
  {a:t0p}(chneg(sslist(a))): chneg_sslist(a)
extern
fun
chpos_sslist_nil{a:t0p}(chpos(sslist(a))): void
and
chpos_sslist_cons
  {a:t0p}(chpos(sslist(a))): chpos(send(a) :: sslist(a))
//
(* ****** ****** *)

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

(* ****** ****** *)
//
abst@ype bit = int
//
macdef B0 = $UN.cast{bit}(0)
macdef B1 = $UN.cast{bit}(1)
//
(* ****** ****** *)
//
extern
fun
chneg_create{ss:type}
  (f: chpos(ss) -<lincloptr1> void): chneg(ss)
//
(* ****** ****** *)

extern
fun int2bits{n:nat} (int(n)): chneg(sslist(bit))

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

implement
int2bits(n) = let
//
fun
fserv{n:nat}
(
  n: int(n), ch: chpos(sslist(bit))
) : void = (
//
if
n > 0
then let
  val n2 = half(n)
  val bit =
  (
    if n = 2*n2 then B0 else B1
  ) : bit // end of [val]
  val ch = chpos_sslist_cons (ch)
  val ((*void*)) = chpos_send (ch, bit)
in
  fserv (n2, ch)
end // end of [then]
else chpos_sslist_nil (ch)
//
) (* end of [fserv] *)
//
in
  chneg_create{sslist(bit)}(llam (ch) => fserv (n, ch))
end // end of [int2bits]

(* ****** ****** *)
//
extern
fun succ_bits (chneg(sslist(bit))): chneg(sslist(bit))
extern
fun add_bits_bits (chneg(sslist(bit)), chneg(sslist(bit))): chneg(sslist(bit))
//
(* ****** ****** *)

typedef bit_ = natLt(2)

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

implement
succ_bits(ch1) = let
//
fun
fserv
(
  ch: chpos(sslist(bit))
, ch1: chneg(sslist(bit))
) : void = let
//
val opt = chneg_sslist (ch1)
//
in
//
case+ opt of
| ~chneg_sslist_nil () => let
    val ch = chpos_sslist_cons (ch)
    val ((*void*)) = chpos_send (ch, B1)
    val ((*void*)) = chpos_sslist_nil (ch)
  in
    // nothing
  end // end of [chneg_sslist_nil]
| ~chneg_sslist_cons (ch1) => let
    val bit = chneg_send_val (ch1)
    val bit_ = $UN.cast{bit_}(bit)
    val ch = chpos_sslist_cons (ch)
  in
    if bit_ = 0
      then let
        val () = chpos_send (ch, B1)
      in
        chpos_chneg_connect (ch, ch1)
      end // end of [then]
      else let
        val () = chpos_send (ch, B0)
      in
        fserv (ch, ch1)
      end // end of [else]
  end // end of [chneg_sslist_cons]
//
end // end of [fserv]
//
in
  chneg_create{sslist(bit)}(llam (ch) => fserv (ch, ch1))
end // end of [succ_bits]

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

implement
add_bits_bits
  (ch1, ch2) = let
//
fun
fserv
(
  ch: chpos(sslist(bit))
, ch1: chneg(sslist(bit))
, ch2: chneg(sslist(bit))
) : void = let
//
val opt1 = chneg_sslist (ch1)
//
in
//
case+ opt1 of
| ~chneg_sslist_nil () =>
    chpos_chneg_connect (ch, ch2)
| ~chneg_sslist_cons (ch1) => let
    val opt2 = chneg_sslist (ch2)
  in
    case+ opt2 of
    | ~chneg_sslist_nil () => let
        val ch = chpos_sslist_cons (ch)
      in
        chpos_chneg_connect (ch, ch1)
      end // end of [chneg_sslist_nil]
    | ~chneg_sslist_cons (ch2) => let
        val b1 = chneg_send_val (ch1)
        and b2 = chneg_send_val (ch2)
        val b1_ = $UN.cast{natLt(2)}(b1)
        and b2_ = $UN.cast{natLt(2)}(b2)
        val ch = chpos_sslist_cons (ch)
      in
        case+ b1_ of
        | 0 => (chpos_send (ch, b2); fserv (ch, ch1, ch2))
        | 1 => (
          case+ b2_ of
          | 0 => (chpos_send (ch, B1); fserv (ch, ch1, ch2))
          | 1 => (chpos_send (ch, B0); fserv (ch, ch1, succ_bits(ch2)))
          ) (* end of [1] *)
      end // end of [chneg_sslist_cons]
  end // end of [chneg_sslist_cons]
//
end // end of [fserv]
//
in
  chneg_create{sslist(bit)}(llam (ch) => fserv (ch, ch1, ch2))
end // end of [add_bits_bits]

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

(* end of [scratch08.dats] *)

(* ****** ****** *)
//
// HX-2014-12-25:
// For the purpose of
// studying session types
//
(* ****** ****** *)
//
abstype send (a:vt@ype)
abstype recv (a:vt@ype)
//
(* ****** ****** *)

abstype
chseq (a:type, b:type)

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

stadef nil = unit
stadef :: (a:type, b:type) = chseq (a, b)

(* ****** ****** *)
//
absvtype chpos(type)
absvtype chneg(type)
//
(* ****** ****** *)
//
extern
fun{a:vt0p}
chpos_send{ss:type}
  (ch: !chpos(send(a) :: ss) >> chpos(ss), x: a): void
extern
fun{a:vt0p}
chpos_recv{ss:type}
  (ch: !chpos(recv(a) :: ss) >> chpos(ss), x: &a? >> _): void
extern
fun{a:vt0p}
chpos_recv_val{ss:type}(ch: !chpos(recv(a) :: ss) >> chpos(ss)): a
//
(* ****** ****** *)
//
extern
fun{a:vt0p}
chneg_recv{ss:type}
  (ch: !chneg(recv(a) :: ss) >> chneg(ss), x: a): void
extern
fun{a:vt0p}
chneg_send{ss:type}
  (ch: !chneg(send(a) :: ss) >> chneg(ss), x: &a? >> _): void
extern
fun{a:vt0p}
chneg_send_val{ss:type}(ch: !chneg(send(a) :: ss) >> chneg(ss)): a
//
(* ****** ****** *)

extern
fun chpos_recv_close (ch: chpos(nil)): void
extern
fun chneg_send_close (ch: chneg(nil)): void

(* ****** ****** *)
//
extern
fun
chpos_chneg_connect{ss:type} (ch1: chpos(ss), ch2: chneg(ss)): void
//
(* ****** ****** *)
//
datatype
sslist (a:t@ype) =
| sslist_nil of (nil)
| sslist_cons of (send(a) :: sslist(a))
//
(*
datavtype
chpos_sslist (a:t@ype) =
| chpos_sslist_nil of ()
| chpos_sslist_cons of (chpos(send(a) :: sslist(a)))
*)
//
datavtype
chneg_sslist (a:t@ype) =
| chneg_sslist_nil of ()
| chneg_sslist_cons of (chneg(send(a) :: sslist(a)))
//
(* ****** ****** *)
//
(*
extern
fun
chpos_sslist
  {a:t0p}(chpos(sslist(a))): chpos_sslist(a)
extern
fun
chneg_sslist_nil{a:t0p}(chneg(sslist(a))): void
and
chneg_sslist_cons
  {a:t0p}(chneg(sslist(a))): chneg(send(a) :: sslist(a))
*)
//
(* ****** ****** *)
//
extern
fun
chneg_sslist
  {a:t0p}(chneg(sslist(a))): chneg_sslist(a)
extern
fun
chpos_sslist_nil{a:t0p}(chpos(sslist(a))): void
and
chpos_sslist_cons
  {a:t0p}(chpos(sslist(a))): chpos(send(a) :: sslist(a))
//
(* ****** ****** *)

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

(* ****** ****** *)
//
abst@ype bit = natLt(2)
//
macdef B0 = $UN.cast{bit}(0)
macdef B1 = $UN.cast{bit}(1)
//
(* ****** ****** *)
//
extern
fun
chneg_create{ss:type}
  (f: chpos(ss) -<lincloptr1> void): chneg(ss)
//
(* ****** ****** *)

extern
fun int2bits{n:nat} (int(n)): chneg(sslist(bit))

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

implement
int2bits (n) = let
//
fun
fserv{n:nat}
(
  n: int(n), ch: chpos(sslist(bit))
) : void = (
//
if
n > 0
then let
  val n2 = half(n)
  val bit = (if n = 2*n2 then 0 else 1): natLt(2)
  val bit = $UN.cast{bit}(bit)
  val ch = chpos_sslist_cons (ch)
  val ((*void*)) = chpos_send (ch, bit)
in
  fserv (n2, ch)
end // end of [then]
else chpos_sslist_nil (ch)
//
) (* end of [fserv] *)
//
in
  chneg_create{sslist(bit)}(llam (ch) => fserv (n, ch))
end // end of [int2bits]

(* ****** ****** *)
//
extern
fun succ_bits (chneg(sslist(bit))): chneg(sslist(bit))
extern
fun add_bits_bits (chneg(sslist(bit)), chneg(sslist(bit))): chneg(sslist(bit))
//
(* ****** ****** *)

implement
succ_bits (ch1) = let
//
fun
fserv
(
  ch: chpos(sslist(bit))
, ch1: chneg(sslist(bit))
) : void = let
//
val opt = chneg_sslist (ch1)
//
in
//
case+ opt of
| ~chneg_sslist_nil () => let
    val ch = chpos_sslist_cons (ch)
    val ((*void*)) = chpos_send (ch, B1)
    val ((*void*)) = chpos_sslist_nil (ch)
  in
    // nothing
  end // end of [chneg_sslist_nil]
| ~chneg_sslist_cons (ch1) => let
    val ch = chpos_sslist_cons (ch)
    val bit = chneg_send_val (ch1)
    val bit = $UN.cast{natLt(0)}(bit)
  in
    if bit = 0
      then let
        val ((*void*)) = chpos_send (ch, B1)
      in
        chpos_chneg_connect (ch, ch1)
      end // end of [then]
      else let
        val ((*void*)) = chpos_send (ch, B0)
      in
        fserv (ch, ch1)
      end // end of [else]
  end // end of [chneg_sslist_cons]
//
end // end of [fserv]
//
in
  chneg_create{sslist(bit)}(llam (ch) => fserv (ch, ch1))
end // end of [succ_bits]

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

implement
add_bits_bits
  (ch1, ch2) = let
//
fun
fserv
(
  ch: chpos(sslist(bit))
, ch1: chneg(sslist(bit))
, ch2: chneg(sslist(bit))
) : void = let
//
val opt1 = chneg_sslist (ch1)
//
in
//
case+ opt1 of
| ~chneg_sslist_nil () =>
    chpos_chneg_connect (ch, ch2)
| ~chneg_sslist_cons (ch1) => let
    val opt2 = chneg_sslist (ch2)
  in
    case+ opt2 of
    | ~chneg_sslist_nil () => let
        val ch = chpos_sslist_cons (ch)
      in
        chpos_chneg_connect (ch, ch1)
      end // end of [chneg_sslist_nil]
    | ~chneg_sslist_cons (ch2) => let
        val b1 = chneg_send_val (ch1)
        and b2 = chneg_send_val (ch2)
        val b1_ = $UN.cast{natLt(2)}(b1)
        and b2_ = $UN.cast{natLt(2)}(b2)
        val ch = chpos_sslist_cons (ch)
      in
        case+ b1_ of
        | 0 => (chpos_send (ch, b2); fserv (ch, ch1, ch2))
        | 1 => (
          case+ b2_ of
          | 0 => (chpos_send (ch, B1); fserv (ch, ch1, ch2))
          | 1 => (chpos_send (ch, B0); fserv (ch, ch1, succ_bits(ch2)))
          ) (* end of [1] *)
      end // end of [chneg_sslist_cons]
  end // end of [chneg_sslist_cons]
//
end // end of [fserv]
//
in
  chneg_create{sslist(bit)}(llam (ch) => fserv (ch, ch1, ch2))
end // end of [add_bits_bits]

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

(* end of [scratch08.dats] *)


Updating: adding PEULER/P16

Updating: adding PEULER/P16

(*
** Project Euler: P16
** See https://projecteuler.net
*)
(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: January 14, 2015
//
(* ****** ****** *)
//
#include "share/atspre_define.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/PEULER/SATS/peuler.sats"
//
(* ****** ****** *)

#define BASE 10

(* ****** ****** *)
//
datatype
dlist(int) =
  | dlist_nil(0) of ()
  | {d:nat | d < BASE}{n:nat}
    dlist_cons(d+n*BASE) of (int(d), dlist(n))
//
(* ****** ****** *)
//
fun
add_dlist_dlist
  {m,n:nat}(m: dlist(m), n: dlist(n)): dlist(m+n)
//
(* ****** ****** *)
//
fun
dlist_gen_exp2
  {n:nat}(n: int(n)): [r:int] (EXP2(n, r) | dlist(r))
//
(* ****** ****** *)

fun dlist_tally{n:nat}(ds: dlist(n)): int

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

(* end of [P16.sats] *)

(*
** Project Euler: P16
** See https://projecteuler.net
*)
(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: January 14, 2015
//
(* ****** ****** *)
//
#include "share/atspre_define.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/PEULER/SATS/peuler.sats"
//
(* ****** ****** *)

#define BASE 10

(* ****** ****** *)
//
datatype
dlist(int) =
  | dlist_nil(0) of ()
  | {d:nat | d < BASE}{n:nat}
    dlist_cons(d+n*BASE) of (int(d), dlist(n))
//
(* ****** ****** *)
//
fun
add_dlist_dlist
  {m,n:nat}
  (m: dlist(m), n: dlist(n)): dlist(m+n)
//
(* ****** ****** *)
//
fun
exp2{n:nat}
  (int(n)): [r:int] (EXP2(n, r) | dlist(r))
//
(* ****** ****** *)

fun dlist_sum{n:nat}(ds: dlist(n)): int

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

(* end of [P16.sats] *)


Error handling

Error handling

%{^
#include "include/common.h"
%}

#include "share/atspre_staload.hats"

#define ATS_DYNLOADFLAG 0

staload "static/fd.sats"
staload "static/error.sats"

implement main () = let
  extern fn perror(string_type): void = "mac#perror"

  val (pf | fd) = socket(AF_UNIX, SOCK_STREAM | ATS_AF_UNIX, ATS_SOCK_STREAM)
in (if fd >= 0 then let
  prval Some_v pf = pf

  val (pf | res) = close(pf | fd)
in (if res = ~1 then let
  prval Some_v e_obl = pf
  val _ = perror "Closing socket"
  prval _ = discharge_error_obligation e_obl
in 2 end
else let
  prval None_v () = pf
in 0 end): int end
else let
  prval None_v () = pf
  val _ = perror "Creating socket"
in 1 end): int end

%{^
#include "include/common.h"
%}

#include "share/atspre_staload.hats"

#define ATS_DYNLOADFLAG 0

staload "static/fd.sats"
staload "static/error.sats"

implement main () = let
  val (pf | fd) = socket(AF_UNIX, SOCK_STREAM | ATS_AF_UNIX, ATS_SOCK_STREAM)
in (if fd >= 0 then let
  prval Some_v pf = pf

  val (pf | res) = close(pf | fd)
in (if res = ~1 then let
  prval Some_v e_obl = pf
  prval _ = discharge_error_obligation e_obl
in 2 end
else let
  prval None_v () = pf
in 0 end): int end
else let
  prval None_v () = pf
in 1 end): int end


Updating: very minorly

Updating: very minorly

(*
#
# QueenPuzzle
#
*)
(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"{$ARDUINO}/staloadall.hats"
//
(* ****** ****** *)

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

(* ****** ****** *)
//
%{^
typedef char *charptr;
%} // end of [%{^]
//
abstype charptr = $extype"charptr"
//
(* ****** ****** *)
//
%{^
#define N 8
int theArray[N] =
{
  0,0,0,0,0,0,0,0
} ;
%} // end of [%{^]
#define N 8
macdef theArray =
  $extval(arrayref(int,N),"theArray")
//
(* ****** ****** *)
//
fnx
find_next
  {n:pos}
(
  A: arrayref(int, n), n: int(n)
) : bool = let
//
fun
loop
(
  i: natLte(n)
) : natLte(n) =
(
if
i < n
then
  if A[i] > 0 then loop (i+1) else i
else n
) (* end of [loop] *)
//
val i0 = loop (0)
//
in
//
if
i0 < n
then
(
  A[i0] := 1; find2_next (A, n, i0)
) (* end of [then] *)
else
(
  A[n-1] := A[n-1] + 1; find2_next (A, n, n-1)
) (* end of [else] *)
//
end // end of [find_next]

and
find2_next
  {n:pos}
(
  A: arrayref(int, n), n: int(n), i: natLt(n)
) : bool = let
//
fun
test
(
  A: arrayref(int, n), i: natLt(n), j: intGte(0)
) : bool =
(
if
j >= i
then true
else
(
if
A[i] = A[j]
then false
else (if (i-j=abs(A[i]-A[j])) then false else test(A, i, j+1))
) (* end of [else] *)
) (* end of [test] *)
//
in
//
if
A[i] <= n
then let
in
//
if
test(A, i, 0)
then
(
  if i+1=n then true else find_next(A, n)
) (* end of [then] *)
else (A[i] := A[i]+1; find2_next(A, n, i))
//
end // end of [then]
else let
  val () = A[i] := 0
in
  if i > 0 then (A[i-1] := A[i-1]+1; find2_next (A, n, i-1)) else false
end // end of [else]
//
end // end of [find2_next]

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

macdef LEDPIN = 13
macdef BAUD_RATE = 9600

(* ****** ****** *)
//
extern
fun
setup (): void = "mac#"
//
implement
setup () = () where
{
//
val () = pinMode(LEDPIN, OUTPUT)
val () = Serial_ptr._begin(BAUD_RATE)
//
} (* end of [setup] *)
//
(* ****** ****** *)
//
implement
fprint_val<int>
  (out, x) = let
//
fun
ndot(n: int): void =
if n > 0 then
(
  Serial_ptr.print(". "); ndot(n-1)
) (* end of [if] *)
//
val () = ndot(x-1)
val () = Serial_ptr.print("Q ")
val () = ndot(N-x)
val () = Serial_ptr.println((*void*))
//
in
  // nothing
end // end of [fprint_val]

(* ****** ****** *)
//
implement
fprint_string (out, x) = Serial_ptr.print(x)
//
(* ****** ****** *)
//
implement
fprint_array$sep<> (out) = ()
//
(* ****** ****** *)
//
extern
fun loop (): void = "mac#"
//
implement
loop () =
myloop() where
{
fun
myloop(): void = let
//
val
out = $extval (FILEref, "0")
//
(*
val () =
randomSeed($UN.cast{uint}(millis()))
*)
//
val A = theArray
val found = find_next (A, N)
//
val () =
if found then
{
  val () =
  fprint_arrayref (out, A, i2sz(N))
  val () = Serial_ptr.println()
} (* end of [then] *)
//
val () =
if ~found then
{
//
  val () =
  fprint_string (out, "All solutions are found!")
  val () = Serial_ptr.println()
//
} (* end of [then] *)
//
val () = digitalWrite(LEDPIN, 1)
val () = delay(250)
val () = digitalWrite(LEDPIN, 0)
val () = delay(1000)
//
in
  myloop ()
end // end of [myloop]
//
} (* end of [loop] *)
//
(* ****** ****** *)

(* end of [QueenPuzzle.dats] *)

(*
#
# QueenPuzzle
#
*)
(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"{$ARDUINO}/staloadall.hats"
//
(* ****** ****** *)

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

(* ****** ****** *)
//
%{^
typedef char *charptr;
%} // end of [%{^]
//
abstype charptr = $extype"charptr"
//
(* ****** ****** *)
//
%{^
#define N 8
int theArray[N] =
{
  0,0,0,0,0,0,0,0
} ;
%} // end of [%{^]
#define N 8
macdef theArray =
  $extval(arrayref(int,N),"theArray")
//
(* ****** ****** *)
//
fnx
find_next
  {n:pos}
(
  A: arrayref(int, n), n: int(n)
) : bool = let
//
fun
loop
(
  i: natLte(n)
) : natLte(n) =
(
if
i < n
then
  if A[i] > 0 then loop (i+1) else i
else n
) (* end of [loop] *)
//
val i0 = loop (0)
//
in
//
if
i0 < n
then
(
  A[i0] := 1; find2_next (A, n, i0)
) (* end of [then] *)
else
(
  A[n-1] := A[n-1] + 1; find2_next (A, n, n-1)
) (* end of [else] *)
//
end // end of [find_next]

and
find2_next
  {n:pos}
(
  A: arrayref(int, n), n: int(n), i: natLt(n)
) : bool = let
//
fun
test
(
  A: arrayref(int, n), i: natLt(n), j: intGte(0)
) : bool =
(
if j >= i then true else
  (if A[i] = A[j] then false else if (i-j=abs(A[i]-A[j])) then false else test (A, i, j+1))
) (* end of [test] *)
//
in
//
if
A[i] <= n
then let
in
//
if test(A, i, 0)
  then
  (if i+1=n then true else find_next(A, n))
  else (A[i] := A[i]+1; find2_next(A, n, i))
//
end // end of [then]
else let
  val () = A[i] := 0
in
  if i > 0 then (A[i-1] := A[i-1]+1; find2_next (A, n, i-1)) else false
end // end of [else]
//
end // end of [find2_next]

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

macdef LEDPIN = 13
macdef BAUD_RATE = 9600

(* ****** ****** *)
//
extern
fun
setup (): void = "mac#"
//
implement
setup () = () where
{
//
val () = pinMode(LEDPIN, OUTPUT)
val () = Serial_ptr._begin(BAUD_RATE)
//
} (* end of [setup] *)
//
(* ****** ****** *)
//
implement
fprint_val<int>
  (out, x) = let
//
fun
ndot(n: int): void =
if n > 0 then
(
  Serial_ptr.print(". "); ndot(n-1)
) (* end of [if] *)
//
val () = ndot(x-1)
val () = Serial_ptr.print("Q ")
val () = ndot(N-x)
val () = Serial_ptr.println((*void*))
//
in
  // nothing
end // end of [fprint_val]

(* ****** ****** *)
//
implement
fprint_string (out, x) = Serial_ptr.print(x)
//
(* ****** ****** *)
//
implement
fprint_array$sep<> (out) = ()
//
(* ****** ****** *)
//
extern
fun loop (): void = "mac#"
//
implement
loop () =
myloop() where
{
fun
myloop(): void = let
//
val
out = $extval (FILEref, "0")
//
(*
val () =
randomSeed($UN.cast{uint}(millis()))
*)
//
val A = theArray
val found = find_next (A, N)
//
val () =
if found then
{
  val () =
  fprint_arrayref (out, A, i2sz(N))
  val () = Serial_ptr.println()
} (* end of [then] *)
//
val () =
if ~found then
{
//
  val () =
  fprint_string (out, "All solutions are found!")
  val () = Serial_ptr.println()
//
} (* end of [then] *)
//
val () = digitalWrite(LEDPIN, 1)
val () = delay(250)
val () = digitalWrite(LEDPIN, 0)
val () = delay(1000)
//
in
  myloop ()
end // end of [myloop]
//
} (* end of [loop] *)
//
(* ****** ****** *)

(* end of [QueenPuzzle.dats] *)


Updating: minorly tidying-up

Updating: minorly tidying-up

(***********************************************************************)
(*                                                                     *)
(*                       ATS/contrib/libats-hwxi                       *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2014 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
** OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
** THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
** IN THE SOFTWARE.
*)

(* ****** ****** *)
//
// HX-2014-06-04: ported from ATS1
//
(* ****** ****** *)
//
// for supporting SIMD on vectors of 2 doubles
//
(* ****** ****** *)

%{#
//
#include "SIMD/CATS/v2df.cats"
//
%} // end of [%{#]

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

#define
ATS_PACKNAME "ATSCNTRB.libats-hwxi.SIMD"
#define
ATS_EXTERN_PREFIX "atscntrb_libatshwxi_SIMD_"

(* ****** ****** *)
//
abst@ype v2df =
$extype"atscntrb_v2df_type"
//
(* ****** ****** *)

val v2df_0_0: v2df = "mac#%"
val v2df_1_1: v2df = "mac#%"

(* ****** ****** *)
//
fun v2df_get_fst (dd: v2df): double = "mac#%"
fun v2df_get_snd (dd: v2df): double = "mac#%"
//
(* ****** ****** *)
//
symintr v2df_make
//
fun
v2df_make_int_int
  (i0: int, i1: int): v2df = "mac#%"
fun
v2df_make_double_double
  (d0: double, d1: double): v2df = "mac#%"
//
overload v2df_make with v2df_make_int_int
overload v2df_make with v2df_make_double_double
//
(* ****** ****** *)
//
fun
add_v2df_v2df
  (dd0: v2df, dd1: v2df): v2df = "mac#%"
fun
sub_v2df_v2df
  (dd0: v2df, dd1: v2df): v2df = "mac#%"
fun
mul_v2df_v2df
  (dd0: v2df, dd1: v2df): v2df = "mac#%"
fun
div_v2df_v2df
  (dd0: v2df, dd1: v2df): v2df = "mac#%"
//
overload + with add_v2df_v2df of 0
overload - with sub_v2df_v2df of 0
overload * with mul_v2df_v2df of 0
overload / with div_v2df_v2df of 0
//
(* ****** ****** *)

(* end of [v2df.sats] *)


Cleaned up the insertion sort example a bit.

// staload _ = "prelude/DATS/integer.dats"

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

staload "contrib/libats-/wdblair/prelude/SATS/array.sats"
staload "contrib/libats-/wdblair/patsolve/SATS/stampseq.sats"

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

// assume T(a:t@ype, xs:stamp) = a

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

typedef cmp_fn(a:t@ype) = {l1,l2:addr} {x1,x2:stamp} (
  !T(a, x1) @ l1, !T(a, x2) @ l2 |
    ptr (l1), ptr (l2)) -> int (sgn(x1-x2))

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

extern
praxi array_sorted_len_lemma
                 {a:t@ype} {l:addr} {xs:stmsq | ordered(xs)} {n:nat} (
    pf: !array_v (a, l, xs, n)
): [sorted(xs, n)] void

extern
praxi array_ordered_lemma
                 {a:t@ype} {l:addr} {n:nat} {xs:stmsq | sorted(xs, n)}  (
    pf: !array_v (a, l, xs, n)
): [ordered(xs)] void

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

(**
    Shorthand to make the example more readable
*)

#define :: array_v_cons
#define nil array_v_nil

macdef offset = ptr_offset
macdef swap = array_ptrswap
macdef split = array_v_split
macdef join = array_v_unsplit

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

fn
sort {a:t@ype} {l:addr} {xs:stmsq} {n:nat} .<n>. (
  pf: array_v (a, l, xs, n) |
    p: ptr l, n: size_t n, sz: size_t (sizeof(a)), cmp: cmp_fn(a)
): [ys:stmsq | ordered(ys)] (
  array_v (a, l, ys, n) | void
)  = let

   (**
       Short hand to abstract sz, which stays the same for the whole
       function.
   *)
  macdef ptrsucc(p) = add_ptr_bsz(,(p), sz)
  macdef ptrpred(p) = sub_ptr_bsz(,(p), sz)

  fun
  loop {m:nat | m <= n}
           {ys:stmsq | ordered(ys)} .<n-m>. (
    pfsorted: array_v (a, l, ys, m),
    pfrem: array_v (a, l+m*sizeof(a), drop(xs, m), n-m) |
      ps: ptr l, pr: ptr (l+m*sizeof(a)), m: size_t (m)
  ): [zs:stmsq | ordered(zs)] (
    array_v (a, l, zs, n) | void
  ) =
    if m = n then let
        prval nil () = pfrem
    in
         (pfsorted | ())
    end
    else let

          fn
          insert {n:nat} {l:addr}
                      {x:stamp} {xs:stmsq | ordered(xs)} .<n>. (
              pfxs: array_v (a, l, xs, n), pfx: T(a, x) @ l + n*sizeof(a) |
                  p: ptr l,  px: ptr (l + n *sizeof(a)), n: size_t n
          ): [ys:stmsq | ordered(ys)] (
                  array_v (a, l, ys, n+1) | void
          ) = let
              prval () = array_sorted_len_lemma (pfxs)
              prval pfxsx = array_v_extend (pfxs, pfx)

              fun
              loop {i:nat | i <= n} {x:stamp}
                       {xs:stmsq | sorted(xs, n) ; lte(x, xs, i, n)} .<i>. (
                  pf: array_v (a, l, insert(xs, i, x), n+1) | px: ptr (l+i*sizeof(a))
              ): [j:nat | sorted(insert(xs, j, x), n+1)] (
                  array_v (a, l, insert(xs, j, x), n+1) | void
              ) =
                  if p = px then let
                      prval  () = equal_ptr_lemma {a} {l} {0,i} (p, px)
                  in
                      #[0 | (pf | ())]
                  end
                  else let
                      val py = ptrpred(px)

                      prval (front, last) = split (pf, offset{a}{l}{i}(p, px, sz))
                      prval pfx :: pfxs = last
                      prval (sortedfront, pfys) = split (front, offset{a}{l}{i-1}(p, py, sz))
                      prval pfy :: pfyss = pfys

                      val sgn = cmp (pfy, pfx | py, px)

                      prval front = join (sortedfront, pfy :: pfyss)
                      prval last = pfx :: pfxs
                      prval () = pf := join (front, last)
                  in
                      if sgn <= 0 then
                          (**
                              Found our final position
                          *)
                          #[i | (pf | ())]
                      else let
                          (**
                              py > px, swap and try again
                          *)
                          val () = swap {a}{l}{n+1}{i-1, i} (pf | py, px, sz)
                          val [i':int] (pfins | ()) = loop {i-1} {x} {xs} (pf | py)
                       in
                           #[i' | (pfins | ())]
                       end
                  end

              val (pfins | ()) = loop {n}{x}{xs} (pfxsx | px)

              prval () = array_ordered_lemma (pfins)
           in
               (pfins | ())
          end

          prval array_v_cons (pfr, pfrss) = pfrem

          val (pfinserted | ()) = insert (pfsorted, pfr | ps, pr, m)
     in
         loop (pfinserted, pfrss | ps, ptrsucc(pr), succ(m))
     end

in
    loop (array_v_nil(), pf | p, p, u2sz(0u))
end

// staload _ = "prelude/DATS/integer.dats"

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

staload "contrib/libats-/wdblair/prelude/SATS/array.sats"
staload "contrib/libats-/wdblair/patsolve/SATS/stampseq.sats"

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

// assume T(a:t@ype, xs:stamp) = a

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

typedef cmp_fn(a:t@ype) = {l1,l2:addr} {x1,x2:stamp} (
  !T(a, x1) @ l1, !T(a, x2) @ l2 |
    ptr (l1), ptr (l2)) -> int (sgn(x1-x2))

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

extern
praxi array_sorted_len_lemma
                 {a:t@ype} {l:addr} {xs:stmsq | ordered(xs)} {n:nat} (
    pf: !array_v (a, l, xs, n)
): [sorted(xs, n)] void

extern
praxi array_ordered_lemma
                 {a:t@ype} {l:addr} {n:nat} {xs:stmsq | sorted(xs, n)}  (
    pf: !array_v (a, l, xs, n)
): [ordered(xs)] void

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

#define :: array_v_cons

fn
sort {a:t@ype} {l:addr} {xs:stmsq} {n:nat} .<n>. (
  pf: array_v (a, l, xs, n) |
    p: ptr l, n: size_t n, sz: size_t (sizeof(a)), cmp: cmp_fn(a)
): [ys:stmsq | ordered(ys)] (
  array_v (a, l, ys, n) | void
)  = let

  fun
  loop {m:nat | m <= n}
           {ys:stmsq | ordered(ys)} .<n-m>. (
    pfsorted: array_v (a, l, ys, m),
    pfrem: array_v (a, l+m*sizeof(a), drop(xs, m), n-m) |
      ps: ptr l, pr: ptr (l+m*sizeof(a)), m: size_t (m)
  ): [zs:stmsq | ordered(zs)] (
    array_v (a, l, zs, n) | void
  ) =
    if m = n then let
        prval array_v_nil () = pfrem
    in
         (pfsorted | ())
    end
    else let

          fn
          insert {n:nat} {l:addr}
                      {x:stamp} {xs:stmsq | ordered(xs)} .<n>. (
              pfxs: array_v (a, l, xs, n), pfx: T(a, x) @ l + n*sizeof(a) |
                  p: ptr l,  px: ptr (l + n *sizeof(a)), n: size_t n
          ): [ys:stmsq | ordered(ys)] (
                  array_v (a, l, ys, n+1) | void
          ) = let
              prval () = array_sorted_len_lemma (pfxs)
              prval pfxsx = array_v_extend (pfxs, pfx)

              fun
              loop {i:nat | i <= n} {x:stamp}
                       {xs:stmsq | sorted(xs, n) ; lte(x, xs, i, n)} .<i>. (
                  pf: array_v (a, l, insert(xs, i, x), n+1) | pi: ptr (l+i*sizeof(a))
              ): [j:nat | sorted(insert(xs, j, x), n+1)] (
                  array_v (a, l, insert(xs, j, x), n+1) | void
              ) =
                  if p = pi then let
                      prval  () = equal_ptr_lemma {a} {l} {0,i} (p, pi)
                  in
                      #[0 | (pf | ())]
                  end
                  else let
                      val q = sub_ptr_bsz(pi, sz)

                      prval (front, last) = array_v_split (pf, ptr_offset{a}{l}{i}(p, pi, sz))
                      prval pfx :: pfxs = last
                      prval (pff, pfis) =
                          array_v_split (front, ptr_offset{a}{l}{i-1}(p, q, sz))
                      prval pfi1 :: pfiss = pfis

                      val sgn = cmp (pfi1, pfx | q, pi)

                      prval front = array_v_unsplit (pff, pfi1 :: pfiss)
                      prval last = pfx :: pfxs
                      prval () = pf := array_v_unsplit (front, last)
                  in
                      if sgn < 0 then
                          (**
                              Found our final position
                          *)
                          #[i | (pf | ())]
                      else let
                          (**
                              pi-1 > pi, swap and try again
                          *)
                          val () = array_ptrswap {a}{l}{n+1}{i-1, i} (pf | q, pi, sz)
                          val [i':int] (pfins | ()) = loop {i-1} {x} {xs} (pf | q)
                       in
                           #[i' | (pfins | ())]
                       end
                  end

              val (pfins | ()) = loop {n}{x}{xs} (pfxsx | px)

              prval () = array_ordered_lemma (pfins)
           in
               (pfins | ())
          end

          prval array_v_cons (pfr, pfrss) = pfrem

          val (pfinserted | ()) = insert (pfsorted, pfr | ps, pr, m)
     in
         loop (pfinserted, pfrss | ps, add_ptr_bsz(pr, sz), succ(m))
     end

in
    loop (array_v_nil(), pf | p, p, u2sz(0u))
end