Updating: improving JSclock

Updating: improving JSclock

(*
//
An example of atscc2js: Wall Clock
//
Author: Hongwei Xi
Authoremail: hwxi AT cs DOT bu DOT edu
Start Time: September, 2014
//
This example is essentially translated from
the JS code at the following site:
//
http://www.neilwallis.com/projects/html5/clock/
//
*)

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

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSCC2JS}/SATS/HTML/canvas-2d/canvas2d.sats"
//
(* ****** ****** *)

macdef PI = JSmath_PI
macdef sin = JSmath_sin and cos = JSmath_cos

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

fun
draw_mark
(
  ctx: canvas2d, i: int
) : void = {
//
val a = PI/30*i
val sa = sin(a)
val ca = cos(a)
val sx = 110 * sa
val sy = 110 * ca
val ex = 120 * sa
val ey = 120 * ca
//
val () = ctx.lineWidth(2)
//
val () = ctx.beginPath()
val () = ctx.moveTo(sx, sy)
val () = ctx.lineTo(ex, ey)
val () = ctx.closePath()
//
val () = ctx.stroke()
//
} (* end of [draw_mark] *)

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

fun
draw_mark2
(
  ctx: canvas2d, i: int
) : void = {
//
val a = PI/30*i
val sa = sin(a)
val ca = cos(a)
val sx =  95 * sa
val sy = ~95 * ca
val ex =  120 * sa
val ey = ~120 * ca
val nx =  80 * sa
val ny = ~80 * ca
//
val () = ctx.fillText(toString(i/5), nx, ny)
//
val () = ctx.lineWidth(8)
//
val () = ctx.beginPath()
val () = ctx.moveTo(sx, sy)
val () = ctx.lineTo(ex, ey)
val () = ctx.closePath()
//
val () = ctx.stroke()
//
} (* end of [draw_mark2] *)

(* ****** ****** *)
//
extern
fun
draw_clock
(
  ctx: canvas2d
, nhr: double, nmin: double, nsec: double
) : void = "mac#" // end-of-fun
//
implement
draw_clock
(
  ctx, nhr, nmin, nsec
) = () where {
//
val () = ctx.clearRect(0.0, 0.0, 300.0, 300.0)
//
// Define gradients for 3D-shadow effect
//
val g1 = ctx.createLinearGradient(0.0, 0.0, 300.0, 300.0)
val () = g1.addColorStop(0.0, "#D83040")
val () = g1.addColorStop(1.0, "#801020")
//
val g2 = ctx.createLinearGradient(0.0, 0.0, 300.0, 300.0)
val () = g2.addColorStop(0.0, "#801020")
val () = g2.addColorStop(1.0, "#D83040")
//
val () = ctx.font("bold 20px arial")
val () = ctx.textAlign("center")
val () = ctx.textBaseline("middle")
val () = ctx.lineWidth(1)
//
val () = ctx.strokeStyle_gradient(g1)
val () = ctx.lineWidth(10)
//
val pf = ctx.save()
val () = ctx.beginPath()
val () = ctx.arc(150.0, 150.0, 138.0, 0.0, 2*PI, true)
val () = ctx.closePath()
val () = ctx.shadowBlur(6)
val () = ctx.shadowOffsetX(4)
val () = ctx.shadowOffsetY(4)
val () = ctx.shadowColor("rgba(0,0,0,0.6)")
val () = ctx.stroke()
val () = ctx.restore(pf.0 | (*none*))
//
val () = ctx.strokeStyle_gradient(g2)
val () = ctx.lineWidth(10)
//
val pf = ctx.save()
val () = ctx.beginPath()
val () = ctx.arc(150.0, 150.0, 129.0, 0.0, 2*PI, true);
val () = ctx.closePath()
val () = ctx.stroke()
val () = ctx.restore(pf.0 | (*none*))
//
val () = ctx.strokeStyle("#222")
//
val pf = ctx.save()
//
val () = ctx.translate(150.0, 150.0)
//
val () = let
//
fun loop
(
  ctx: canvas2d, i: int
) : void =
(
if
i <= 60
then let
  val () =
  (
    if i % 5 != 0
      then draw_mark (ctx, i) else draw_mark2 (ctx, i)
    // end of [if]
  ) : void // end of [val]
in
  loop (ctx, i+1)
end // end of [then]
else () // end of [else]
) (* end of [loop] *)
//
in
  loop (ctx, 1)
end // end of [val]
//
val ampm =
  (if (nhr < 12.0) then "AM" else "PM"): string
//
val () = ctx.strokeStyle("#000")
val () = ctx.lineWidth(1)
val () = ctx.strokeRect(21.0, ~14.0, 44.0, 27.0)
val () = ctx.fillText(ampm, 43.0, 0.0)
val () = ctx.lineWidth(6)
//
val () =
{
  val pf = ctx.save()
  val () = ctx.rotate(nhr*PI/6)
  val () = ctx.beginPath()
  val () = ctx.moveTo(0.0, 10.0)
  val () = ctx.lineTo(0.0, ~60.0)
  val () = ctx.closePath()
  val () = ctx.stroke()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () =
{
  val pf = ctx.save()
  val () = ctx.rotate(nmin*PI/30)
  val () = ctx.beginPath()
  val () = ctx.moveTo(0.0, 20.0)
  val () = ctx.lineTo(0.0, ~110.0)
  val () = ctx.closePath()
  val () = ctx.stroke()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () = ctx.lineWidth (3)
val () = ctx.strokeStyle("#E33")
//
val () =
{
  val pf = ctx.save()
  val () = ctx.rotate(nsec*PI/30)
  val () = ctx.beginPath()
  val () = ctx.moveTo(0.0, 20.0)
  val () = ctx.lineTo(0.0, ~110.0)
  val () = ctx.closePath()
  val () = ctx.stroke()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () = ctx.fillStyle("#000")
//
val () =
{
  val pf = ctx.save()
  val () = ctx.beginPath()
  val () = ctx.arc(0.0, 0.0, 6.5, 0.0, 2*PI, true)
  val () = ctx.closePath()
  val () = ctx.fill()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () = ctx.restore (pf.0 | (*none*))
//
} (* end of [where] *) // [draw_clock]
//
(* ****** ****** *)

%{$
//
var
canvas =
document.getElementById("Patsoptaas-Evaluate-Canvas");
var context = canvas.getContext( '2d' );
//
var w = canvas.width
var h = canvas.height
var xc = w / 2
var yc = h / 2
var wh = Math.min (w, h)
var alpha = wh / 300
//
function
draw2_clock()
{
var date = new Date() ;
var secs = date.getSeconds()
var mins = date.getMinutes()
var mins = mins + secs / 60.0
var hours = date.getHours()
var hours = hours + mins / 60.0
//
context.save();
context.translate(xc-wh/2, yc-wh/2);
context.scale (alpha, alpha);
draw_clock(context, hours, mins, secs);
context.restore();
//
setTimeout(draw2_clock, 500);
//
return;
//
} // end of [draw2_clock]
//
jQuery(document).ready(function(){draw2_clock();});
//
%} // end of [%{$]

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

(* end of [myclock1-2.dats] *)

(*
//
An example of atscc2js: Wall Clock
//
Author: Hongwei Xi
Authoremail: hwxi AT cs DOT bu DOT edu
Start Time: September, 2014
//
This example is essentially translated from
the JS code at the following site:
//
http://www.neilwallis.com/projects/html5/clock/
//
*)

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

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSCC2JS}/SATS/HTML/canvas-2d/canvas2d.sats"
//
(* ****** ****** *)

macdef PI = JSmath_PI
macdef sin = JSmath_sin and cos = JSmath_cos

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

fun
draw_mark
(
  ctx: canvas2d, i: int
) : void = {
//
val a = PI/30*i
val sa = sin(a)
val ca = cos(a)
val sx = 110 * sa
val sy = 110 * ca
val ex = 120 * sa
val ey = 120 * ca
//
val () = ctx.lineWidth(2)
//
val () = ctx.beginPath()
val () = ctx.moveTo(sx, sy)
val () = ctx.lineTo(ex, ey)
val () = ctx.closePath()
//
val () = ctx.stroke()
//
} (* end of [draw_mark] *)

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

fun
draw_mark2
(
  ctx: canvas2d, i: int
) : void = {
//
val a = PI/30*i
val sa = sin(a)
val ca = cos(a)
val sx =  95 * sa
val sy = ~95 * ca
val ex =  120 * sa
val ey = ~120 * ca
val nx =  80 * sa
val ny = ~80 * ca
//
val () = ctx.fillText(toString(i/5), nx, ny)
//
val () = ctx.lineWidth(8)
//
val () = ctx.beginPath()
val () = ctx.moveTo(sx, sy)
val () = ctx.lineTo(ex, ey)
val () = ctx.closePath()
//
val () = ctx.stroke()
//
} (* end of [draw_mark2] *)

(* ****** ****** *)
//
extern
fun
draw_clock
(
  ctx: canvas2d
, nhr: double, nmin: double, nsec: double
) : void = "mac#" // end-of-fun
//
implement
draw_clock
(
  ctx, nhr, nmin, nsec
) = () where {
//
val () = ctx.clearRect(0.0, 0.0, 300.0, 300.0)
//
// Define gradients for 3D-shadow effect
//
val g1 = ctx.createLinearGradient(0.0, 0.0, 300.0, 300.0)
val () = g1.addColorStop(0.0, "#D83040")
val () = g1.addColorStop(1.0, "#801020")
//
val g2 = ctx.createLinearGradient(0.0, 0.0, 300.0, 300.0)
val () = g2.addColorStop(0.0, "#801020")
val () = g2.addColorStop(1.0, "#D83040")
//
val () = ctx.font("bold 20px arial")
val () = ctx.textAlign("center")
val () = ctx.textBaseline("middle")
val () = ctx.lineWidth(1)
//
val () = ctx.strokeStyle_gradient(g1)
val () = ctx.lineWidth(10)
//
val pf = ctx.save()
val () = ctx.beginPath()
val () = ctx.arc(150.0, 150.0, 138.0, 0.0, 2*PI, true)
val () = ctx.closePath()
val () = ctx.shadowBlur(6)
val () = ctx.shadowOffsetX(4)
val () = ctx.shadowOffsetY(4)
val () = ctx.shadowColor("rgba(0,0,0,0.6)")
val () = ctx.stroke()
val () = ctx.restore(pf.0 | (*none*))
//
val () = ctx.strokeStyle_gradient(g2)
val () = ctx.lineWidth(10)
//
val pf = ctx.save()
val () = ctx.beginPath()
val () = ctx.arc(150.0, 150.0, 129.0, 0.0, 2*PI, true);
val () = ctx.closePath()
val () = ctx.stroke()
val () = ctx.restore(pf.0 | (*none*))
//
val () = ctx.strokeStyle("#222")
//
val pf = ctx.save()
//
val () = ctx.translate(150.0, 150.0)
//
val () = let
//
fun loop
(
  ctx: canvas2d, i: int
) : void =
(
if
i <= 60
then let
  val () =
  (
    if i % 5 != 0
      then draw_mark (ctx, i) else draw_mark2 (ctx, i)
    // end of [if]
  ) : void // end of [val]
in
  loop (ctx, i+1)
end // end of [then]
else () // end of [else]
) (* end of [loop] *)
//
in
  loop (ctx, 1)
end // end of [val]
//
val ampm =
  (if (nhr < 12.0) then "AM" else "PM"): string
//
val () = ctx.strokeStyle("#000")
val () = ctx.lineWidth(1)
val () = ctx.strokeRect(21.0, ~14.0, 44.0, 27.0)
val () = ctx.fillText(ampm, 43.0, 0.0)
val () = ctx.lineWidth(6)
//
val () =
{
  val pf = ctx.save()
  val () = ctx.rotate(nhr*PI/6)
  val () = ctx.beginPath()
  val () = ctx.moveTo(0.0, 10.0)
  val () = ctx.lineTo(0.0, ~60.0)
  val () = ctx.closePath()
  val () = ctx.stroke()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () =
{
  val pf = ctx.save()
  val () = ctx.rotate(nmin*PI/30)
  val () = ctx.beginPath()
  val () = ctx.moveTo(0.0, 20.0)
  val () = ctx.lineTo(0.0, ~110.0)
  val () = ctx.closePath()
  val () = ctx.stroke()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () = ctx.lineWidth (3)
val () = ctx.strokeStyle("#E33")
//
val () =
{
  val pf = ctx.save()
  val () = ctx.rotate(nsec*PI/30)
  val () = ctx.beginPath()
  val () = ctx.moveTo(0.0, 20.0)
  val () = ctx.lineTo(0.0, ~110.0)
  val () = ctx.closePath()
  val () = ctx.stroke()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () = ctx.fillStyle("#000")
//
val () =
{
  val pf = ctx.save()
  val () = ctx.beginPath()
  val () = ctx.arc(0.0, 0.0, 6.5, 0.0, 2*PI, true)
  val () = ctx.closePath()
  val () = ctx.fill()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () = ctx.restore (pf.0 | (*none*))
//
} (* end of [where] *) // [draw_clock]
//
(* ****** ****** *)

%{$
//
var
canvas =
document.getElementById("Patsoptaas-Evaluate-Canvas");
var context = canvas.getContext( '2d' );
//
var w = canvas.w
var h = canvas.h
var xc = w / 2
var yc = h / 2
var wh = Math.min (w, h)
var alpha = wh / 300
//
function
draw2_clock()
{
var date = new Date() ;
var secs = date.getSeconds()
var mins = date.getMinutes()
var mins = mins + secs / 60.0
var hours = date.getHours()
var hours = hours + mins / 60.0
//
context.save();
context.translate(xc-wh/2, yc-wh/2);
context.scale (alpha, alpha);
draw_clock(context, hours, mins, secs);
context.restore();
//
setTimeout(draw2_clock, 500);
//
return;
//
} // end of [draw2_clock]
//
jQuery(document).ready(function(){draw2_clock();});
//
%} // end of [%{$]

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

(* end of [myclock1-2.dats] *)


Use array

Use array

(*
 * For LinkSprite 16X2 LCD Keypad Shield for Arduino
 * http://store.linksprite.com/linksprite-16x2-lcd-keypad-shield-for-arduino-version-b/
 * http://www.linksprite.com/wiki/index.php5?title=16_X_2_LCD_Keypad_Shield_for_Arduino
 *)
#define ATS_DYNLOADFLAG 0 // no dynloading at run-time
#include "share/atspre_define.hats"
#include "share/atspre_staload.hats"
staload "SATS/arduino.sats"
staload "SATS/lcd.sats"
staload UN = "prelude/SATS/unsafe.sats"

%{
inline uint8_t atspre_uint8_bit_or(uint8_t a, uint8_t b) { return (a | b); }
inline uint8_t atspre_uint8_bit_and(uint8_t a, uint8_t b) { return (a & b); }
%}
extern fun uint8_bit_or: (uint8, uint8) -> uint8 = "mac#atspre_uint8_bit_or"
extern fun uint8_bit_and: (uint8, uint8) -> uint8 = "mac#atspre_uint8_bit_and"

(* Private struct *)
vtypedef LCD_struct = @{
  rs_pin          = uint8 // LOW: command.  HIGH: character.
, rw_pin          = uint8 // LOW: write to LCD.  HIGH: read from LCD.
, enable_pin      = uint8 // activated by a HIGH pulse.
, displayfunction = uint8
, displaycontrol  = uint8
, displaymode     = uint8
, numlines        = uint8
, currline        = uint8
, data_pins       = @[uint8][4]
}
absvtype LCD_minus_struct (l:addr)
extern castfn
LCD_takeout_struct (* xxx Should lock *)
(
  tcp: !LCD >> LCD_minus_struct l
) : #[l:addr] (LCD_struct @ l | ptr l)
extern praxi
LCD_addback_struct (* xxx Should unlock *)
  {l:addr}
(
  pfat: LCD_struct @ l
| tcp: !LCD_minus_struct l >> LCD
) : void

(* Low level functions *)
extern fun lcd_display: {l:addr} (!LCD_struct @ l | ptr l) -> void
extern fun lcd_command: {l:addr} (!LCD_struct @ l | ptr l, uint8) -> void
extern fun lcd_send: {l:addr} (!LCD_struct @ l | ptr l, uint8, HIGHLOW) -> void
extern fun lcd_pulseEnable: {l:addr} (!LCD_struct @ l | ptr l) -> void
extern fun lcd_write4bits: {l:addr} (!LCD_struct @ l | ptr l, uint8) -> void

local
  var _global_lcd_struct: LCD_struct
in
  implement lcd_open (rs, rw, enable, d0, d1, d2, d3) = let
    val lcd = $UN.castvwtp0 (addr@_global_lcd_struct)
    val (pfat | p) = LCD_takeout_struct (lcd)
    val () = p->rs_pin     := rs
    val () = p->rw_pin     := rw
    val () = p->enable_pin := enable
    val () = p->data_pins.[0] := d0
    val () = p->data_pins.[1] := d1
    val () = p->data_pins.[2] := d2
    val () = p->data_pins.[3] := d3
    val () = pinMode (p->rs_pin, OUTPUT)
    val () = pinMode (p->rw_pin, OUTPUT)
    val () = pinMode (p->enable_pin, OUTPUT)
    val LCD_4BITMODE = $UN.cast 0x00
    val LCD_2LINE    = $UN.cast 0x08
    val LCD_5x8DOTS  = $UN.cast 0x00
    val () = p->displayfunction := uint8_bit_or (LCD_4BITMODE, uint8_bit_or (LCD_2LINE, LCD_5x8DOTS))
    prval () = LCD_addback_struct(pfat | lcd)
    fun lcd_begin (lcd: !LCD, lines: uint8): void = {
      val (pfat | p) = LCD_takeout_struct (lcd)
      val () = p->numlines := lines
      val () = p->currline := $UN.cast 0
      val () = _delay_us 50000.0
      val () = digitalWrite (p->rs_pin, LOW)
      val () = digitalWrite (p->enable_pin, LOW)
      val () = digitalWrite (p->rw_pin, LOW)
      val displayfunction = p->displayfunction
      // this is according to the hitachi HD44780 datasheet / figure 24, pg 46
      // we start in 8bit mode, try to set 4 bit mode
      val () = lcd_write4bits (pfat | p, $UN.cast 0x03)
      val () = _delay_us 4500.0
      val () = lcd_write4bits (pfat | p, $UN.cast 0x03) // second try
      val () = _delay_us 4500.0
      val () = lcd_write4bits (pfat | p, $UN.cast 0x03) // third go!
      val () = _delay_us 150.0
      val () = lcd_write4bits (pfat | p, $UN.cast 0x02) // finally, set to 4-bit interface
      // finally, set # lines, font size, etc.
      val LCD_FUNCTIONSET = $UN.cast 0x20
      val () = lcd_command (pfat | p, uint8_bit_or (LCD_FUNCTIONSET, displayfunction))
      // turn the display on with no cursor or blinking default
      val LCD_DISPLAYON = $UN.cast 0x04
      val LCD_CURSOROFF = $UN.cast 0x00
      val LCD_BLINKOFF  = $UN.cast 0x00
      val () = p->displaycontrol := uint8_bit_or (LCD_DISPLAYON, uint8_bit_or (LCD_CURSOROFF, LCD_BLINKOFF))
      val () = lcd_display (pfat | p)
      // Initialize to default text direction (for romance languages)
      val LCD_ENTRYLEFT           = $UN.cast 0x02
      val LCD_ENTRYSHIFTDECREMENT = $UN.cast 0x00
      val () = p->displaymode := uint8_bit_or (LCD_ENTRYLEFT, LCD_ENTRYSHIFTDECREMENT)
      val displaymode = p->displaymode
      // set the entry mode
      val LCD_ENTRYMODESET = $UN.cast 0x04
      val () = lcd_command (pfat | p, uint8_bit_or (LCD_ENTRYMODESET, displaymode))
      prval () = LCD_addback_struct(pfat | lcd)
      // clear it off
      val () = lcd_clear lcd
    }
    val () = lcd_begin (lcd, $UN.cast 2)
  in
    lcd
  end
end

implement lcd_close (lcd) = {
  val () = $UN.castvwtp0(lcd) (* Consume lcd *)
}

implement lcd_clear (lcd) = {
  val LCD_CLEARDISPLAY = $UN.cast 0x01
  val (pfat | p) = LCD_takeout_struct (lcd)
  val () = lcd_command (pfat | p, LCD_CLEARDISPLAY) // clear display, set cursor position to zero
  prval () = LCD_addback_struct(pfat | lcd)
  val () = _delay_us 2000.0 // this command takes a long time!
}

implement lcd_setCursor (lcd, col, row) = {
  val LCD_SETDDRAMADDR = $UN.cast 0x80
  val row_ofs = if row > 0 then 0x40 else 0x00
  val (pfat | p) = LCD_takeout_struct (lcd)
  val () = lcd_command(pfat | p,  uint8_bit_or (LCD_SETDDRAMADDR, col + $UN.cast row_ofs))
  prval () = LCD_addback_struct(pfat | lcd)
}

implement lcd_print (lcd, str, start, len) = {
  fun w (lcd: !LCD, p: ptr): void = {
    val c = $UN.ptr0_get<uint8> (p)
    val () = lcd_write (lcd, c)
  }
  fun loop (lcd: !LCD, p: ptr, r: int): void = {
    val () = if r > 0 then (w (lcd, p); loop (lcd, ptr_succ<char> (p), r - 1))
  }
  val p0 = string2ptr (str)
  val p0 = ptr_add<char> (p0, start)
  val () = loop (lcd, p0, len)
}

implement lcd_write (lcd, value) = {
  val (pfat | p) = LCD_takeout_struct (lcd)
  val () = lcd_send (pfat | p, value, HIGH)
  prval () = LCD_addback_struct(pfat | lcd)
}

implement lcd_display (pfat | p) = {
  val LCD_DISPLAYON = $UN.cast 0x04
  val () = p->displaycontrol := LCD_DISPLAYON
  val displaycontrol = p->displaycontrol
  val LCD_DISPLAYCONTROL = $UN.cast 0x08
  val () = lcd_command (pfat | p, uint8_bit_or (LCD_DISPLAYCONTROL, displaycontrol))
}

implement lcd_command (pfat | p, value) = {
  val () = lcd_send (pfat | p, value, LOW)
}

implement lcd_send (pfat | p, value, mode) = {
  val () = digitalWrite (p->rs_pin, mode)
  val () = digitalWrite (p->rw_pin, LOW)
  val () = lcd_write4bits (pfat | p, value >> 4)
  val () = lcd_write4bits (pfat | p, value)
}

implement lcd_pulseEnable (pfat | p) = {
  val () = digitalWrite (p->enable_pin, LOW)
  val () = _delay_us 1.0
  val () = digitalWrite (p->enable_pin, HIGH)
  val () = _delay_us 1.0 // enable pulse must be >450ns
  val () = digitalWrite (p->enable_pin, LOW)
  val () = _delay_us 100.0 // commands need > 37us to settle
}

implement lcd_write4bits (pfat | p, value) = {
  fun uint8_to_highlow (v: uint8): HIGHLOW = $UN.cast (uint8_bit_and (v, $UN.cast 0x01))
  val () = pinMode (p->data_pins.[0], OUTPUT)
  val () = digitalWrite (p->data_pins.[0], uint8_to_highlow (value >> 0))
  val () = pinMode (p->data_pins.[1], OUTPUT)
  val () = digitalWrite (p->data_pins.[1], uint8_to_highlow (value >> 1))
  val () = pinMode (p->data_pins.[2], OUTPUT)
  val () = digitalWrite (p->data_pins.[2], uint8_to_highlow (value >> 2))
  val () = pinMode (p->data_pins.[3], OUTPUT)
  val () = digitalWrite (p->data_pins.[3], uint8_to_highlow (value >> 3))
  val () = lcd_pulseEnable (pfat | p)
}

(*
 * For LinkSprite 16X2 LCD Keypad Shield for Arduino
 * http://store.linksprite.com/linksprite-16x2-lcd-keypad-shield-for-arduino-version-b/
 * http://www.linksprite.com/wiki/index.php5?title=16_X_2_LCD_Keypad_Shield_for_Arduino
 *)
#define ATS_DYNLOADFLAG 0 // no dynloading at run-time
#include "share/atspre_define.hats"
#include "share/atspre_staload.hats"
staload "SATS/arduino.sats"
staload "SATS/lcd.sats"
staload UN = "prelude/SATS/unsafe.sats"

%{
inline uint8_t atspre_uint8_bit_or(uint8_t a, uint8_t b) { return (a | b); }
inline uint8_t atspre_uint8_bit_and(uint8_t a, uint8_t b) { return (a & b); }
%}
extern fun uint8_bit_or: (uint8, uint8) -> uint8 = "mac#atspre_uint8_bit_or"
extern fun uint8_bit_and: (uint8, uint8) -> uint8 = "mac#atspre_uint8_bit_and"

(* Private struct *)
vtypedef LCD_struct = @{
  rs_pin          = uint8 // LOW: command.  HIGH: character.
, rw_pin          = uint8 // LOW: write to LCD.  HIGH: read from LCD.
, enable_pin      = uint8 // activated by a HIGH pulse.
, data_pins       = @(uint8, uint8, uint8, uint8)
, displayfunction = uint8
, displaycontrol  = uint8
, displaymode     = uint8
, numlines        = uint8
, currline        = uint8
}
absvtype LCD_minus_struct (l:addr)
extern castfn
LCD_takeout_struct (* xxx Should lock *)
(
  tcp: !LCD >> LCD_minus_struct l
) : #[l:addr] (LCD_struct @ l | ptr l)
extern praxi
LCD_addback_struct (* xxx Should unlock *)
  {l:addr}
(
  pfat: LCD_struct @ l
| tcp: !LCD_minus_struct l >> LCD
) : void

(* Low level functions *)
extern fun lcd_display: {l:addr} (!LCD_struct @ l | ptr l) -> void
extern fun lcd_command: {l:addr} (!LCD_struct @ l | ptr l, uint8) -> void
extern fun lcd_send: {l:addr} (!LCD_struct @ l | ptr l, uint8, HIGHLOW) -> void
extern fun lcd_pulseEnable: {l:addr} (!LCD_struct @ l | ptr l) -> void
extern fun lcd_write4bits: {l:addr} (!LCD_struct @ l | ptr l, uint8) -> void

local
  var _global_lcd_struct: LCD_struct
in
  implement lcd_open (rs, rw, enable, d0, d1, d2, d3) = let
    val lcd = $UN.castvwtp0 (addr@_global_lcd_struct)
    val (pfat | p) = LCD_takeout_struct (lcd)
    val () = p->rs_pin     := rs
    val () = p->rw_pin     := rw
    val () = p->enable_pin := enable
    val () = p->data_pins  := @(d0, d1, d2, d3)
    val () = pinMode (p->rs_pin, OUTPUT)
    val () = pinMode (p->rw_pin, OUTPUT)
    val () = pinMode (p->enable_pin, OUTPUT)
    val LCD_4BITMODE = $UN.cast 0x00
    val LCD_2LINE    = $UN.cast 0x08
    val LCD_5x8DOTS  = $UN.cast 0x00
    val () = p->displayfunction := uint8_bit_or (LCD_4BITMODE, uint8_bit_or (LCD_2LINE, LCD_5x8DOTS))
    prval () = LCD_addback_struct(pfat | lcd)
    fun lcd_begin (lcd: !LCD, lines: uint8): void = {
      val (pfat | p) = LCD_takeout_struct (lcd)
      val () = p->numlines := lines
      val () = p->currline := $UN.cast 0
      val () = _delay_us 50000.0
      val () = digitalWrite (p->rs_pin, LOW)
      val () = digitalWrite (p->enable_pin, LOW)
      val () = digitalWrite (p->rw_pin, LOW)
      val displayfunction = p->displayfunction
      // this is according to the hitachi HD44780 datasheet / figure 24, pg 46
      // we start in 8bit mode, try to set 4 bit mode
      val () = lcd_write4bits (pfat | p, $UN.cast 0x03)
      val () = _delay_us 4500.0
      val () = lcd_write4bits (pfat | p, $UN.cast 0x03) // second try
      val () = _delay_us 4500.0
      val () = lcd_write4bits (pfat | p, $UN.cast 0x03) // third go!
      val () = _delay_us 150.0
      val () = lcd_write4bits (pfat | p, $UN.cast 0x02) // finally, set to 4-bit interface
      // finally, set # lines, font size, etc.
      val LCD_FUNCTIONSET = $UN.cast 0x20
      val () = lcd_command (pfat | p, uint8_bit_or (LCD_FUNCTIONSET, displayfunction))
      // turn the display on with no cursor or blinking default
      val LCD_DISPLAYON = $UN.cast 0x04
      val LCD_CURSOROFF = $UN.cast 0x00
      val LCD_BLINKOFF  = $UN.cast 0x00
      val () = p->displaycontrol := uint8_bit_or (LCD_DISPLAYON, uint8_bit_or (LCD_CURSOROFF, LCD_BLINKOFF))
      val () = lcd_display (pfat | p)
      // Initialize to default text direction (for romance languages)
      val LCD_ENTRYLEFT           = $UN.cast 0x02
      val LCD_ENTRYSHIFTDECREMENT = $UN.cast 0x00
      val () = p->displaymode := uint8_bit_or (LCD_ENTRYLEFT, LCD_ENTRYSHIFTDECREMENT)
      val displaymode = p->displaymode
      // set the entry mode
      val LCD_ENTRYMODESET = $UN.cast 0x04
      val () = lcd_command (pfat | p, uint8_bit_or (LCD_ENTRYMODESET, displaymode))
      prval () = LCD_addback_struct(pfat | lcd)
      // clear it off
      val () = lcd_clear lcd
    }
    val () = lcd_begin (lcd, $UN.cast 2)
  in
    lcd
  end
end

implement lcd_close (lcd) = {
  val () = $UN.castvwtp0(lcd) (* Consume lcd *)
}

implement lcd_clear (lcd) = {
  val LCD_CLEARDISPLAY = $UN.cast 0x01
  val (pfat | p) = LCD_takeout_struct (lcd)
  val () = lcd_command (pfat | p, LCD_CLEARDISPLAY) // clear display, set cursor position to zero
  prval () = LCD_addback_struct(pfat | lcd)
  val () = _delay_us 2000.0 // this command takes a long time!
}

implement lcd_setCursor (lcd, col, row) = {
  val LCD_SETDDRAMADDR = $UN.cast 0x80
  val row_ofs = if row > 0 then 0x40 else 0x00
  val (pfat | p) = LCD_takeout_struct (lcd)
  val () = lcd_command(pfat | p,  uint8_bit_or (LCD_SETDDRAMADDR, col + $UN.cast row_ofs))
  prval () = LCD_addback_struct(pfat | lcd)
}

implement lcd_print (lcd, str, start, len) = {
  fun w (lcd: !LCD, p: ptr): void = {
    val c = $UN.ptr0_get<uint8> (p)
    val () = lcd_write (lcd, c)
  }
  fun loop (lcd: !LCD, p: ptr, r: int): void = {
    val () = if r > 0 then (w (lcd, p); loop (lcd, ptr_succ<char> (p), r - 1))
  }
  val p0 = string2ptr (str)
  val p0 = ptr_add<char> (p0, start)
  val () = loop (lcd, p0, len)
}

implement lcd_write (lcd, value) = {
  val (pfat | p) = LCD_takeout_struct (lcd)
  val () = lcd_send (pfat | p, value, HIGH)
  prval () = LCD_addback_struct(pfat | lcd)
}

implement lcd_display (pfat | p) = {
  val LCD_DISPLAYON = $UN.cast 0x04
  val () = p->displaycontrol := LCD_DISPLAYON
  val displaycontrol = p->displaycontrol
  val LCD_DISPLAYCONTROL = $UN.cast 0x08
  val () = lcd_command (pfat | p, uint8_bit_or (LCD_DISPLAYCONTROL, displaycontrol))
}

implement lcd_command (pfat | p, value) = {
  val () = lcd_send (pfat | p, value, LOW)
}

implement lcd_send (pfat | p, value, mode) = {
  val () = digitalWrite (p->rs_pin, mode)
  val () = digitalWrite (p->rw_pin, LOW)
  val () = lcd_write4bits (pfat | p, value >> 4)
  val () = lcd_write4bits (pfat | p, value)
}

implement lcd_pulseEnable (pfat | p) = {
  val () = digitalWrite (p->enable_pin, LOW)
  val () = _delay_us 1.0
  val () = digitalWrite (p->enable_pin, HIGH)
  val () = _delay_us 1.0 // enable pulse must be >450ns
  val () = digitalWrite (p->enable_pin, LOW)
  val () = _delay_us 100.0 // commands need > 37us to settle
}

implement lcd_write4bits (pfat | p, value) = {
  fun uint8_to_highlow (v: uint8): HIGHLOW = $UN.cast (uint8_bit_and (v, $UN.cast 0x01))
  val () = pinMode (p->data_pins.0, OUTPUT)
  val () = digitalWrite (p->data_pins.0, uint8_to_highlow (value >> 0))
  val () = pinMode (p->data_pins.1, OUTPUT)
  val () = digitalWrite (p->data_pins.1, uint8_to_highlow (value >> 1))
  val () = pinMode (p->data_pins.2, OUTPUT)
  val () = digitalWrite (p->data_pins.2, uint8_to_highlow (value >> 2))
  val () = pinMode (p->data_pins.3, OUTPUT)
  val () = digitalWrite (p->data_pins.3, uint8_to_highlow (value >> 3))
  val () = lcd_pulseEnable (pfat | p)
}


Write lcd_begin (cont.)

Write lcd_begin (cont.)

#define ATS_DYNLOADFLAG 0 // no dynloading at run-time
staload "SATS/arduino.sats"
staload "SATS/lcd.sats"
staload UN = "prelude/SATS/unsafe.sats"

%{
inline uint8_t atspre_uint8_bit_or(uint8_t a, uint8_t b) {
  return (a | b);
}
%}
extern fun uint8_bit_or: (uint8, uint8) -> uint8 = "mac#atspre_uint8_bit_or"

(* Private struct *)
vtypedef LCD_struct = @{
  rs_pin          = uint8 // LOW: command.  HIGH: character.
, rw_pin          = uint8 // LOW: write to LCD.  HIGH: read from LCD.
, enable_pin      = uint8 // activated by a HIGH pulse.
, data_pins       = @(uint8, uint8, uint8, uint8)
, displayfunction = uint8
, displaycontrol  = uint8
, displaymode     = uint8
, numlines        = uint8
, currline        = uint8
}
absvtype LCD_minus_struct (l:addr)
extern castfn
LCD_takeout_struct
(
  tcp: !LCD >> LCD_minus_struct l
) : #[l:addr] (LCD_struct @ l | ptr l)
extern praxi
LCD_addback_struct
  {l:addr}
(
  pfat: LCD_struct @ l
| tcp: !LCD_minus_struct l >> LCD
) : void

local
  var _global_lcd_struct: LCD_struct
in
  implement lcd_open (rs, rw, enable, d0, d1, d2, d3) = let
    val lcd = $UN.castvwtp0 (addr@_global_lcd_struct)
    val (pfat | p) = LCD_takeout_struct (lcd)
    val () = p->rs_pin     := rs
    val () = p->rw_pin     := rw
    val () = p->enable_pin := enable
    val () = p->data_pins  := @(d0, d1, d2, d3)
    val () = pinMode (p->rs_pin, OUTPUT)
    val () = pinMode (p->rw_pin, OUTPUT)
    val () = pinMode (p->enable_pin, OUTPUT)
    val LCD_4BITMODE = $UN.cast 0x00
    val LCD_1LINE    = $UN.cast 0x00
    val LCD_5x8DOTS  = $UN.cast 0x00
    val () = p->displayfunction := uint8_bit_or (LCD_4BITMODE, uint8_bit_or (LCD_1LINE, LCD_5x8DOTS))
    prval () = LCD_addback_struct(pfat | lcd)
    fun lcd_begin (lcd: !LCD, lines: uint8): void = {
      val (pfat | p) = LCD_takeout_struct (lcd)
      val () = p->numlines := lines
      val () = p->currline := $UN.cast 0
      val () = _delay_ms 50000.0
      val () = digitalWrite (p->rs_pin, LOW)
      val () = digitalWrite (p->enable_pin, LOW)
      val () = digitalWrite (p->rw_pin, LOW)
      prval () = LCD_addback_struct(pfat | lcd)
      // this is according to the hitachi HD44780 datasheet / figure 24, pg 46
      // we start in 8bit mode, try to set 4 bit mode
      val () = lcd_write4bits (lcd, $UN.cast 0x03)
      val () = _delay_ms 4500.0
      val () = lcd_write4bits (lcd, $UN.cast 0x03) // second try
      val () = _delay_ms 4500.0
      val () = lcd_write4bits (lcd, $UN.cast 0x03) // third go!
      val () = _delay_ms 150.0
      val () = lcd_write4bits (lcd, $UN.cast 0x02) // finally, set to 4-bit interface
      // xxx
    }
    val () = lcd_begin (lcd, $UN.cast 1)
  in
    lcd
  end
end

implement lcd_close (lcd) = {
  val () = $UN.castvwtp0(lcd) (* Consume lcd *)
}

implement lcd_write4bits (lcd, value) = {
  val (pfat | p) = LCD_takeout_struct (lcd)
  // xxx
  prval () = LCD_addback_struct(pfat | lcd)
}

#define ATS_DYNLOADFLAG 0 // no dynloading at run-time
staload "SATS/arduino.sats"
staload "SATS/lcd.sats"
staload UN = "prelude/SATS/unsafe.sats"

%{
inline uint8_t atspre_uint8_bit_or(uint8_t a, uint8_t b) {
  return (a | b);
}
%}
extern fun uint8_bit_or: (uint8, uint8) -> uint8 = "mac#atspre_uint8_bit_or"

(* Private struct *)
vtypedef LCD_struct = @{
  rs_pin          = uint8 // LOW: command.  HIGH: character.
, rw_pin          = uint8 // LOW: write to LCD.  HIGH: read from LCD.
, enable_pin      = uint8 // activated by a HIGH pulse.
, data_pins       = @(uint8, uint8, uint8, uint8)
, displayfunction = uint8
, displaycontrol  = uint8
, displaymode     = uint8
, numlines        = uint8
, currline        = uint8
}
absvtype LCD_minus_struct (l:addr)
extern castfn
LCD_takeout_struct
(
  tcp: !LCD >> LCD_minus_struct l
) : #[l:addr] (LCD_struct @ l | ptr l)
extern praxi
LCD_addback_struct
  {l:addr}
(
  pfat: LCD_struct @ l
| tcp: !LCD_minus_struct l >> LCD
) : void

local
  var _global_lcd_struct: LCD_struct
in
  implement lcd_open (rs, rw, enable, d0, d1, d2, d3) = let
    val lcd = $UN.castvwtp0 (addr@_global_lcd_struct)
    val (pfat | p) = LCD_takeout_struct (lcd)
    val () = p->rs_pin     := rs
    val () = p->rw_pin     := rw
    val () = p->enable_pin := enable
    val () = p->data_pins  := @(d0, d1, d2, d3)
    val () = pinMode (p->rs_pin, OUTPUT)
    val () = pinMode (p->rw_pin, OUTPUT)
    val () = pinMode (p->enable_pin, OUTPUT)
    val LCD_4BITMODE = $UN.cast 0x00
    val LCD_1LINE    = $UN.cast 0x00
    val LCD_5x8DOTS  = $UN.cast 0x00
    val () = p->displayfunction := uint8_bit_or (LCD_4BITMODE, uint8_bit_or (LCD_1LINE, LCD_5x8DOTS))
    // xxx
    prval () = LCD_addback_struct(pfat | lcd)
  in
    lcd
  end
end

implement lcd_close (lcd) = {
  val () = $UN.castvwtp0(lcd) (* Consume lcd *)
}

implement lcd_write4bits (lcd, value) = {
  val (pfat | p) = LCD_takeout_struct (lcd)
  // xxx
  prval () = LCD_addback_struct(pfat | lcd)
}


Add more opcodes

Add more opcodes

(* ****** ****** *)
//
// chip8-loop.dats
// Implementation of functions that handle the main emulation loop.
//
(* ****** ****** *)

#ifndef CHIP8_MAIN
#include "./../staloadall.hats"
#endif

staload STDLIB = "libats/libc/SATS/stdlib.sats"

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

local
  assume opcode_type = '{
    p = byte,
    Vx = breg,
    Vy = breg,
    n = byte,
    kk = byte,
    nnn = word
  }

  val interrupted = ref<bool>(false)

  fun fetch(): word = opc where {
    val b_hi = Mem(w2imem(PC.get()))
    val () = PC.incr(w_0x1)
    val b_lo = Mem(w2imem(PC.get()))
    val () = PC.incr(w_0x1)
    val opc = (b2w(b_hi) lsl 0x8) lor b2w(b_lo)
  }

  fun decode(opc: word): opcode = '{
    p = w2b((opc lsr 0xC) land w_0xF),
    Vx = V((opc lsr 0x8) land w_0xF),
    Vy = V((opc lsr 0x4) land w_0xF),
    n = w2b(opc land w_0xF),
    kk = w2b(opc land w_0xFF),
    nnn = opc land w_0xFFF
  }

  fun execute(opc: opcode): void =
    let
      fun check_p(p: byte): bool = opc.p = p
      fun check_pn(p: byte, n: byte): bool = opc.p = p && opc.n = n
      fun check_pkk(p: byte, kk: byte): bool = opc.p = p && opc.kk = kk
      fun check_pnnn(p: byte, nnn: word): bool = opc.p = p && opc.nnn = nnn
      fun get_Vx(): byte = (opc.Vx).get()
      fun set_Vx(b: byte): void = (opc.Vx).set(b)
      fun get_Vy(): byte = (opc.Vy).get()
      fun set_Vy(b: byte): void = (opc.Vy).set(b)
      fun set_Vf(test: bool): void =
        if test then (V(w_0xF)).set(b_0x1) else (V(w_0xF)).set(b_0x0)

      overload Vx with get_Vx
      overload Vx with set_Vx
      overload Vy with get_Vy
      overload Vy with set_Vy
      overload Vf with set_Vf
    in
      ifcase
      | check_pkk(b_0x0, i2b(0xE0)) => clear_screen()
      | check_pkk(b_0x0, i2b(0xEE)) => PC.set(stack_pop())
      | check_p(b_0x1) => PC.set(opc.nnn)
      | check_p(b_0x2) => (stack_push(PC.get()); PC.set(opc.nnn))
      | check_p(b_0x3) => if (Vx() = opc.kk) then PC.incr(w_0x2)
      | check_p(b_0x4) => if (Vx() != opc.kk) then PC.incr(w_0x2)
      | check_p(b_0x5) => if (Vx() = Vy()) then PC.incr(w_0x2)
      | check_p(b_0x6) => Vx(opc.kk)
      | check_p(b_0x7) => Vx(Vx() + opc.kk)
      | check_pn(b_0x8, b_0x0) => Vx(Vy())
      | check_pn(b_0x8, b_0x1) => Vx(Vx() lor Vy())
      | check_pn(b_0x8, b_0x2) => Vx(Vx() land Vy())
      | check_pn(b_0x8, b_0x3) => Vx(Vx() lxor Vy())
      | check_pn(b_0x8, b_0x4) => (Vf(Vx() > (b_0xFF - Vy())); Vx(Vx() + Vy()))
      | check_pn(b_0x8, b_0x5) => (Vf(Vx() > Vy()); Vx(Vx() - Vy()))
      | check_pn(b_0x8, b_0x6) => (Vf((Vx() land b_0x1) = b_0x1); Vx(Vx() lsr 1))
      | check_pn(b_0x8, b_0x7) => (Vf(Vy() > Vx()); Vx(Vy() - Vx()))
      | check_pn(b_0x8, b_0xE) => (Vf((Vx() lsr 7) = b_0x1); Vx(Vx() lsl 1))
      | check_pn(b_0x9, b_0x0) => if (Vx() != Vy()) then PC.incr(w_0x2)
      | check_p(b_0xA) => I.set(opc.nnn)
      | check_p(b_0xB) => PC.set(b2w((V(w_0x0)).get()) + opc.nnn)
      | check_p(b_0xC) => Vx(i2b($STDLIB.rand() % 256) land opc.kk)
      | check_p(b_0xD) => draw_y(0) where {
        val () = (V(0xF)).set(b_0x0)
        val x = b2i(Vx.get())
        val y = b2i(Vy.get())
        val height = w2i(n)

        fun draw_x(row: byte, x_off: int, y_off: int):<cloref1> void =
          if x_off < SPR_WIDTH && x + x_off < SCR_WIDTH then
            let
              val _x = $UN.cast{natLt(SCR_WIDTH)}(x + x_off)
              val _y = $UN.cast{natLt(SCR_HEIGHT)}(y + y_off)
              val pix = (row lsr (SPR_WIDTH - 1 - x_off)) land b_0x1
              val () = if pix = b_0x1 then (
                if Scr(_x, _y) = b_0x1 then (
                  (V(0xF)).set(b_0x1);
                  Scr(_x, _y, b_0x0)
                ) else Scr(_x, _y, b_0x1)
              )
            in
              draw_x(row, succ(x_off), y_off)
            end

        fun draw_y(y_off: int):<cloref1> void = (
          if y_off < height && y + y_off < SCR_HEIGHT then (
            draw_x(Mem($UN.cast{imem}(I.get() + y_off)), 0, y_off);
            draw_y(succ(y_off))
          )
        )
      }

      | _ => $raise UnknownOpcode((b2w(opc.p) lsl 0xC) lor opc.nnn)
    end

  fun exec_insns(): void =
    if has_time() then execute(opc) where {
      val opc = fetch()
      val opc = decode(opc)
    }

in
  implement quit() = !interrupted := true

  implement game_loop(dpy) =
    let
      val () = exec_insns()
      val () = poll_kb()
      val () = if sync_clock() then update_display(dpy)
    in
      if not !interrupted then game_loop(dpy)
    end
end

(* End of chip8-loop.dats *)

(* ****** ****** *)
//
// chip8-loop.dats
// Implementation of functions that handle the main emulation loop.
//
(* ****** ****** *)

#ifndef CHIP8_MAIN
#include "./../staloadall.hats"
#endif

staload STDLIB = "libats/libc/SATS/stdlib.sats"

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

local
  assume opcode_type = '{
    p = byte,
    Vx = breg,
    Vy = breg,
    n = byte,
    kk = byte,
    nnn = word
  }

  val interrupted = ref<bool>(false)

  fun fetch(): word = opc where {
    val b_hi = Mem(w2imem(PC.get()))
    val () = PC.incr(w_0x1)
    val b_lo = Mem(w2imem(PC.get()))
    val () = PC.incr(w_0x1)
    val opc = (b2w(b_hi) lsl 0x8) lor b2w(b_lo)
  }

  fun decode(opc: word): opcode = '{
    p = w2b((opc lsr 0xC) land w_0xF),
    Vx = V((opc lsr 0x8) land w_0xF),
    Vy = V((opc lsr 0x4) land w_0xF),
    n = w2b(opc land w_0xF),
    kk = w2b(opc land w_0xFF),
    nnn = opc land w_0xFFF
  }

  fun execute(opc: opcode): void =
    let
      fun check_p(p: byte): bool = opc.p = p
      fun check_pn(p: byte, n: byte): bool = opc.p = p && opc.n = n
      fun check_pkk(p: byte, kk: byte): bool = opc.p = p && opc.kk = kk
      fun check_pnnn(p: byte, nnn: word): bool = opc.p = p && opc.nnn = nnn
      fun get_Vx(): byte = (opc.Vx).get()
      fun set_Vx(b: byte): void = (opc.Vx).set(b)
      fun get_Vy(): byte = (opc.Vy).get()
      fun set_Vy(b: byte): void = (opc.Vy).set(b)
      fun set_Vf(test: bool): void =
        if test then (V(w_0xF)).set(b_0x1) else (V(w_0xF)).set(b_0x0)

      overload Vx with get_Vx
      overload Vx with set_Vx
      overload Vy with get_Vy
      overload Vy with set_Vy
      overload Vf with set_Vf
    in
      ifcase
      | check_pkk(b_0x0, i2b(0xE0)) => clear_screen()
      | check_pkk(b_0x0, i2b(0xEE)) => PC.set(stack_pop())
      | check_p(b_0x1) => PC.set(opc.nnn)
      | check_p(b_0x2) => (stack_push(PC.get()); PC.set(opc.nnn))
      | check_p(b_0x3) => if (Vx() = opc.kk) then PC.incr(w_0x2)
      | check_p(b_0x4) => if (Vx() != opc.kk) then PC.incr(w_0x2)
      | check_p(b_0x5) => if (Vx() = Vy()) then PC.incr(w_0x2)
      | check_p(b_0x6) => Vx(opc.kk)
      | check_p(b_0x7) => Vx(Vx() + opc.kk)
      | check_pn(b_0x8, b_0x0) => Vx(Vy())
      | check_pn(b_0x8, b_0x1) => Vx(Vx() lor Vy())
      | check_pn(b_0x8, b_0x2) => Vx(Vx() land Vy())
      | check_pn(b_0x8, b_0x3) => Vx(Vx() lxor Vy())
      | check_pn(b_0x8, b_0x4) => (Vf(Vx() > (b_0xFF - Vy())); Vx(Vx() + Vy()))
      | check_pn(b_0x8, b_0x5) => (Vf(Vx() > Vy()); Vx(Vx() - Vy()))
      | check_pn(b_0x8, b_0x6) => (Vf((Vx() land b_0x1) = b_0x1); Vx(Vx() lsr 1))
      | check_pn(b_0x8, b_0x7) => (Vf(Vy() > Vx()); Vx(Vy() - Vx()))
      | check_pn(b_0x8, b_0xE) => (Vf((Vx() lsr 7) = b_0x1); Vx(Vx() lsl 1))
      | check_pn(b_0x9, b_0x0) => if (Vx() != Vy()) then PC.incr(w_0x2)
      | check_p(b_0xA) => I.set(opc.nnn)
      | check_p(b_0xB) => PC.set(b2w((V(0)).get()) + opc.nnn)
      | check_p(b_0xC) => Vx(i2b($STDLIB.rand() % 256) land opc.kk)
      | _ => $raise UnknownOpcode((b2w(opc.p) lsl 0xC) lor opc.nnn)
    end

  fun exec_insns(): void =
    if has_time() then execute(opc) where {
      val opc = fetch()
      val opc = decode(opc)
    }

in
  implement quit() = !interrupted := true

  implement game_loop(dpy) =
    let
      val () = exec_insns()
      val () = poll_kb()
      val () = if sync_clock() then update_display(dpy)
    in
      if not !interrupted then game_loop(dpy)
    end
end

(* End of chip8-loop.dats *)


Some fix

Some fix

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

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

#define LED 13
#define SENSOR 0

implement main () = {
  fun loop () = {
    val w = analogRead (SENSOR)
    val () = digitalWrite (LED, HIGH)
    val () = delay ($UN.cast w)
    val () = digitalWrite (LED, LOW)
    val () = delay ($UN.cast w)
    val () = loop ()
  }
  val () = pinMode (LED, OUTPUT)
  val () = loop ()
}

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

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

#define LED 13
#define SENSOR 0
#define BLINK_DELAY_MS 500.0

implement main () = {
  fun loop () = {
    val w = analogRead(SENSOR)
    val () = digitalWrite (LED, HIGH)
    val () = delay ($UN.cast w)
    val () = digitalWrite (LED, LOW)
    val () = delay ($UN.cast w)
    val () = loop ()
  }
  val () = pinMode (LED, OUTPUT)
  val () = loop ()
}


Updating: very minorly tidying-up

Updating: very minorly tidying-up

(***********************************************************************)
(*                                                                     *)
(*                         Applied Type System                         *)
(*                                                                     *)
(***********************************************************************)

(*
** ATS/Postiats - Unleashing the Potential of Types!
** Copyright (C) 2011-2013 Hongwei Xi, ATS Trustful Software, Inc.
** All rights reserved
**
** ATS is free software;  you can  redistribute it and/or modify it under
** the terms of the GNU LESSER GENERAL PUBLIC LICENSE as published by the
** Free Software Foundation; either version 2.1, or (at your option)  any
** later version.
**
** ATS is distributed in the hope that it will be useful, but WITHOUT ANY
** WARRANTY; without  even  the  implied  warranty  of MERCHANTABILITY or
** FITNESS FOR A PARTICULAR PURPOSE.  See the  GNU General Public License
** for more details.
**
** You  should  have  received  a  copy of the GNU General Public License
** along  with  ATS;  see the  file COPYING.  If not, please write to the
** Free Software Foundation,  51 Franklin Street, Fifth Floor, Boston, MA
** 02110-1301, USA.
*)

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

(*
** Start Time: April, 2013
**
** Author: William Blair
** Authoremail: wdblair AT bu DOT edu
**
** Author: Hongwei Xi
** Authoremail: gmhwxi AT gmail DOT com
*)

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

%{#
#include "libats-/wdblair/SMT/Z3/CATS/z3.cats"
%} // end of [%{#]

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

#define ATS_PACKNAME "ATSCNTRB.libats-wdblair.Z3"
#define ATS_STALOADFLAG 0 // no static loading at run-time
#define ATS_EXTERN_PREFIX "atscntrb_" // prefix for external names

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

#define
ATSCNTRB_SML_Z3_Z3_HEADER
#include "./z3_header.sats"

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

(*
Z3_config Z3_mk_config ()
Create a configuration.
*)
fun Z3_mk_config (): Z3_config = "mac#%"

(*
void Z3_del_config (__in Z3_config c)
Delete the given configuration object.
*)
fun Z3_del_config (cfg: Z3_config): void = "mac#%"

(*
void Z3_set_param_value
(
  __in Z3_config c, __in Z3_string param_id, __in Z3_string param_value
)
Set a configuration parameter.
*)
fun Z3_set_param_value
(
  cfg: !Z3_config, p_id: Z3_string, p_val: Z3_string
) : void = "mac#%" // end of [Z3_set_param_value]

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

(*
Z3_context Z3_mk_context (__in Z3_config c)
Create a context using the given configuration.
*)
(*
fun Z3_mk_context (cfg: !Z3_config): Z3_context = "mac#%"
*)

(*
Z3_context Z3_mk_context_rc (__in Z3_config c)
Create a context using the given configuration. This function is similar to
Z3_mk_context. However, in the context returned by this function, the user
is responsible for managing Z3_ast reference counters. Managing reference
counters is a burden and error-prone, but allows the user to use the memory
more efficiently. The user must invoke Z3_inc_ref for any Z3_ast returned
by Z3, and Z3_dec_ref whenever the Z3_ast is not needed anymore. This idiom
is similar to the one used in BDD (binary decision diagrams) packages such
as CUDD.
*)

fun Z3_mk_context_rc (cfg: !Z3_config): Z3_context = "mac#%"

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

(*
void
Z3_del_context (__in Z3_context c)
Delete the given logical context.
*)
fun Z3_del_context (ctx: Z3_context): void = "mac#%"

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

(*
void Z3_inc_ref (__in Z3_context c, __in Z3_ast a)
Increment the reference counter of the given AST. The context c should
have been created using Z3_mk_context_rc. This function is a NOOP if c
was created using Z3_mk_context.
*)
fun Z3_inc_ref{l:addr}
  (ctx: !Z3_context, a: !Z3_ast l): Z3_ast (l) = "mac#%"
// end of [Z3_inc_ref]

(*
void
Z3_dec_ref (__in Z3_context c, __in Z3_ast a)
Decrement the reference counter of the given AST. The context c should
have been created using Z3_mk_context_rc. This function is a NOOP if c
was created using Z3_mk_context.
*)
fun Z3_dec_ref (ctx: !Z3_context, a: Z3_ast): void = "mac#%"

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

(*
Z3_bool
Z3_get_param_value
(
  __in Z3_context c
, __in Z3_string param_id, __out Z3_string_ptr param_value
)
*)
fun Z3_get_param_value
(
  ctx: !Z3_context, p_id: Z3_string, p_val: &ptr? >> opt (Z3_string, b)
) : #[b:bool] bool (b) = "mac#%"

(*
void
Z3_update_param_value
(__in Z3_context c, __in Z3_string param_id, __in Z3_string param_value)
*)
fun Z3_update_param_value
  (ctx: !Z3_context, p_id: Z3_string, p_val: Z3_string): void = "mac#%"
// end of [Z3_update_param_value]

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

(*
void
Z3_interrupt (__in Z3_context c)
Interrupt the execution of a Z3 procedure. This procedure can be used to
interrupt: solvers, simplifiers and tactics.
*)
fun Z3_interrupt (ctx: !Z3_context): void = "mac#%"

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

#include "./z3_accessor.sats"

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

#include "./z3_params.sats"
#include "./z3_params_descrs.sats"

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

#include "./z3_symbol.sats"

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

#include "./z3_sort.sats"

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

#include "./z3_constapp.sats"

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

#include "./z3_propeq.sats"

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

#include "./z3_arithmetic.sats"

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

#include "./z3_bitvector.sats"

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

#include "./z3_numerals.sats"

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

#include "./z3_array.sats"

(*
#include "./z3_quantifier.sats"
*)

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

#include "./z3_accessor.sats"
#include "./z3_modifier.sats"

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

#include "./z3_model.sats"

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

#include "./z3_parser.sats"

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

(*
#include "./z3_interlog.sats"
*)

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

#include "./z3_quantifier.sats"

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

#include "./z3_stringconv.sats"

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

(*
#include "./z3_parserint.sats"
#include "./z3_errhandle.sats"
*)

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

#include "./z3_fixedpoint.sats"

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

(*
#include "./z3_ast_map"
#include "./z3_ast_vector"
*)

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

#include "./z3_goal.sats"

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

#include "./z3_tactic_probe.sats"

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

#include "./z3_solver.sats"

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

#include "./z3_stats.sats"

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

(* end of [z3.sats] *)

(***********************************************************************)
(*                                                                     *)
(*                         Applied Type System                         *)
(*                                                                     *)
(***********************************************************************)

(*
** ATS/Postiats - Unleashing the Potential of Types!
** Copyright (C) 2011-2013 Hongwei Xi, ATS Trustful Software, Inc.
** All rights reserved
**
** ATS is free software;  you can  redistribute it and/or modify it under
** the terms of the GNU LESSER GENERAL PUBLIC LICENSE as published by the
** Free Software Foundation; either version 2.1, or (at your option)  any
** later version.
**
** ATS is distributed in the hope that it will be useful, but WITHOUT ANY
** WARRANTY; without  even  the  implied  warranty  of MERCHANTABILITY or
** FITNESS FOR A PARTICULAR PURPOSE.  See the  GNU General Public License
** for more details.
**
** You  should  have  received  a  copy of the GNU General Public License
** along  with  ATS;  see the  file COPYING.  If not, please write to the
** Free Software Foundation,  51 Franklin Street, Fifth Floor, Boston, MA
** 02110-1301, USA.
*)

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

(*
** Start Time: April, 2013
**
** Author: William Blair
** Authoremail: wdblair AT bu DOT edu
**
** Author: Hongwei Xi
** Authoremail: gmhwxi AT gmail DOT com
*)

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

%{#
#include "contrib/libats-/wdblair/SMT/Z3/CATS/z3.cats"
%} // end of [%{#]

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

#define ATS_PACKNAME "ATSCNTRB.libats-wdblair.Z3"
#define ATS_STALOADFLAG 0 // no static loading at run-time
#define ATS_EXTERN_PREFIX "atscntrb_" // prefix for external names

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

#define
ATSCNTRB_SML_Z3_Z3_HEADER
#include "./z3_header.sats"

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

(*
Z3_config Z3_mk_config ()
Create a configuration.
*)
fun Z3_mk_config (): Z3_config = "mac#%"

(*
void Z3_del_config (__in Z3_config c)
Delete the given configuration object.
*)
fun Z3_del_config (cfg: Z3_config): void = "mac#%"

(*
void Z3_set_param_value
(
  __in Z3_config c, __in Z3_string param_id, __in Z3_string param_value
)
Set a configuration parameter.
*)
fun Z3_set_param_value
(
  cfg: !Z3_config, p_id: Z3_string, p_val: Z3_string
) : void = "mac#%" // end of [Z3_set_param_value]

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

(*
Z3_context Z3_mk_context (__in Z3_config c)
Create a context using the given configuration.
*)
(*
fun Z3_mk_context (cfg: !Z3_config): Z3_context = "mac#%"
*)

(*
Z3_context Z3_mk_context_rc (__in Z3_config c)
Create a context using the given configuration. This function is similar to
Z3_mk_context. However, in the context returned by this function, the user
is responsible for managing Z3_ast reference counters. Managing reference
counters is a burden and error-prone, but allows the user to use the memory
more efficiently. The user must invoke Z3_inc_ref for any Z3_ast returned
by Z3, and Z3_dec_ref whenever the Z3_ast is not needed anymore. This idiom
is similar to the one used in BDD (binary decision diagrams) packages such
as CUDD.
*)

fun Z3_mk_context_rc (cfg: !Z3_config): Z3_context = "mac#%"

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

(*
void
Z3_del_context (__in Z3_context c)
Delete the given logical context.
*)
fun Z3_del_context (ctx: Z3_context): void = "mac#%"

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

(*
void Z3_inc_ref (__in Z3_context c, __in Z3_ast a)
Increment the reference counter of the given AST. The context c should
have been created using Z3_mk_context_rc. This function is a NOOP if c
was created using Z3_mk_context.
*)
fun Z3_inc_ref{l:addr}
  (ctx: !Z3_context, a: !Z3_ast l): Z3_ast (l) = "mac#%"
// end of [Z3_inc_ref]

(*
void
Z3_dec_ref (__in Z3_context c, __in Z3_ast a)
Decrement the reference counter of the given AST. The context c should
have been created using Z3_mk_context_rc. This function is a NOOP if c
was created using Z3_mk_context.
*)
fun Z3_dec_ref (ctx: !Z3_context, a: Z3_ast): void = "mac#%"

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

(*
Z3_bool
Z3_get_param_value
(
  __in Z3_context c
, __in Z3_string param_id, __out Z3_string_ptr param_value
)
*)
fun Z3_get_param_value
(
  ctx: !Z3_context, p_id: Z3_string, p_val: &ptr? >> opt (Z3_string, b)
) : #[b:bool] bool (b) = "mac#%"

(*
void
Z3_update_param_value
(__in Z3_context c, __in Z3_string param_id, __in Z3_string param_value)
*)
fun Z3_update_param_value
  (ctx: !Z3_context, p_id: Z3_string, p_val: Z3_string): void = "mac#%"
// end of [Z3_update_param_value]

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

(*
void
Z3_interrupt (__in Z3_context c)
Interrupt the execution of a Z3 procedure. This procedure can be used to
interrupt: solvers, simplifiers and tactics.
*)
fun Z3_interrupt (ctx: !Z3_context): void = "mac#%"

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

#include "./z3_accessor.sats"

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

#include "./z3_params.sats"
#include "./z3_params_descrs.sats"

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

#include "./z3_symbol.sats"

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

#include "./z3_sort.sats"

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

#include "./z3_constapp.sats"

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

#include "./z3_propeq.sats"

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

#include "./z3_arithmetic.sats"

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

#include "./z3_bitvector.sats"

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

#include "./z3_numerals.sats"

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

#include "./z3_array.sats"

(*
#include "./z3_quantifier.sats"
*)

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

#include "./z3_accessor.sats"
#include "./z3_modifier.sats"

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

#include "./z3_model.sats"

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

#include "./z3_parser.sats"

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

(*
#include "./z3_interlog.sats"
*)

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

#include "./z3_quantifier.sats"

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

#include "./z3_stringconv.sats"

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

(*
#include "./z3_parserint.sats"
#include "./z3_errhandle.sats"
*)

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

#include "./z3_fixedpoint.sats"

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

(*
#include "./z3_ast_map"
#include "./z3_ast_vector"
*)

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

#include "./z3_goal.sats"

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

#include "./z3_tactic_probe.sats"

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

#include "./z3_solver.sats"

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

#include "./z3_stats.sats"

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

(* end of [z3.sats] *)


Snatch tcp_socket_connection_receive

Snatch tcp_socket_connection_receive

#include "share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"
staload "libmbedats/SATS/net_lwip_Socket_Socket.sats"
staload "libmbedats/SATS/net_lwip_Socket_Endpoint.sats"
staload "libmbedats/SATS/net_lwip_Socket_TCPSocketConnection.sats"

vtypedef TCPSocketConnection_struct = @{
  is_connected= bool
, sock=         Socket
, endpoint=     Endpoint
}

absvtype TCPSocketConnection_minus_struct (l:addr)

extern castfn
TCPSocketConnection_takeout_struct
(
  tcp: !TCPSocketConnection >> TCPSocketConnection_minus_struct l
) : #[l:addr] (TCPSocketConnection_struct @ l | ptr l)

extern praxi
TCPSocketConnection_addback_struct
  {l:addr}
(
  pfat: TCPSocketConnection_struct @ l
| tcp: !TCPSocketConnection_minus_struct l >> TCPSocketConnection
) : void

implement
tcp_socket_connection_open () = let
  val (pfgc, pfat | p) = ptr_alloc<TCPSocketConnection_struct> ()
  val () = p->is_connected := false
  val () = p->sock := socket_open ()
  val () = p->endpoint := endpoint_open ()
in
  $UN.castvwtp0{TCPSocketConnection}((pfat, pfgc | p))
end

implement
tcp_socket_connection_is_connected (tcp) = let
  val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
  val r = p->is_connected
  prval () = TCPSocketConnection_addback_struct(pfat | tcp)
in
  r
end

implement
tcp_socket_connection_connect (tcp, host, port) = let
  val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
  val rs = socket_initsock (p->sock, SOCK_STREAM)
  val ret = if rs = false then false else let
      val re = endpoint_set_address (p->endpoint, host, port)
    in
      if re = false then false else let
          abst@ype socklen_t = $extype"socklen_t"
          extern fun lwip_connect: (int, struct_sockaddr_in_p, socklen_t) -> int = "mac#"
          val fd = socket_sock_fd (p->sock)
          val rh = endpoint_remoteHost (p->endpoint)
          val rc = lwip_connect (fd, rh, $UN.cast (sizeof<struct_sockaddr_in>))
        in
          if rc < 0 then let
              val _ = socket_finisock (p->sock, true)
            in
              false
            end else let
              val () = p->is_connected := true
            in
              true
            end
        end
    end
  prval () = TCPSocketConnection_addback_struct(pfat | tcp)
in
  ret
end

implement
tcp_socket_connection_receive (tcp) = let
  val is_connected = tcp_socket_connection_is_connected (tcp)
  val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
  val fd = socket_sock_fd (p->sock)
  val blocking = socket_blocking (p->sock)
  prval () = TCPSocketConnection_addback_struct(pfat | tcp)
in
  if (fd < 0) orelse (not is_connected) then None_vt () else let
      val b = if blocking then true else let
                val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
                val tout = socket_timeout (p->sock)
                val r = socket_wait_readable (p->sock, tout)
                prval () = TCPSocketConnection_addback_struct(pfat | tcp)
              in
                r
              end
    in
      if b then let
          extern fun lwip_recv: (int, ptr, size_t, int) -> int = "mac#"
          #define N 127
          #define CNUL '\000'
          val N1 = succ(N)
          val (pf, pfgc | p) = malloc_gc (i2sz N1)
          val n = lwip_recv (fd, p, i2sz N, 0)
          val () = $UN.ptr0_set<char>(ptr_add<char>(p, n), CNUL)
          val s = $UN.castvwtp0{strptr}((pf, pfgc | p))
        in
          Some_vt (s)
        end else None_vt ()
    end
end

implement
tcp_socket_connection_close (tcp) = {
  val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
  val () = endpoint_close (p->endpoint)
  val () = socket_close (p->sock)
  val () = $UN.castvwtp0((pfat | p))
  val () = __free (tcp) where {
    extern fun __free {vt:vtype} (x: vt): void = "atspre_mfree_gc"
  }
}

#include "share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"
staload "libmbedats/SATS/net_lwip_Socket_Socket.sats"
staload "libmbedats/SATS/net_lwip_Socket_Endpoint.sats"
staload "libmbedats/SATS/net_lwip_Socket_TCPSocketConnection.sats"

vtypedef TCPSocketConnection_struct = @{
  is_connected= bool
, sock=         Socket
, endpoint=     Endpoint
}

absvtype TCPSocketConnection_minus_struct (l:addr)

extern castfn
TCPSocketConnection_takeout_struct
(
  tcp: !TCPSocketConnection >> TCPSocketConnection_minus_struct l
) : #[l:addr] (TCPSocketConnection_struct @ l | ptr l)

extern praxi
TCPSocketConnection_addback_struct
  {l:addr}
(
  pfat: TCPSocketConnection_struct @ l
| tcp: !TCPSocketConnection_minus_struct l >> TCPSocketConnection
) : void

implement
tcp_socket_connection_open () = let
  val (pfgc, pfat | p) = ptr_alloc<TCPSocketConnection_struct> ()
  val () = p->is_connected := false
  val () = p->sock := socket_open ()
  val () = p->endpoint := endpoint_open ()
in
  $UN.castvwtp0{TCPSocketConnection}((pfat, pfgc | p))
end

implement
tcp_socket_connection_is_connected (tcp) = let
  val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
  val r = p->is_connected
  prval () = TCPSocketConnection_addback_struct(pfat | tcp)
in
  r
end

implement
tcp_socket_connection_connect (tcp, host, port) = let
  val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
  val rs = socket_initsock (p->sock, SOCK_STREAM)
  val ret = if rs = false then false else let
      val re = endpoint_set_address (p->endpoint, host, port)
    in
      if re = false then false else let
          abst@ype socklen_t = $extype"socklen_t"
          extern fun lwip_connect: (int, struct_sockaddr_in_p, socklen_t) -> int = "mac#"
          val fd = socket_sock_fd (p->sock)
          val rh = endpoint_remoteHost (p->endpoint)
          val rc = lwip_connect (fd, rh, $UN.cast (sizeof<struct_sockaddr_in>))
        in
          if rc < 0 then let
              val _ = socket_finisock (p->sock, true)
            in
              false
            end else let
              val () = p->is_connected := true
            in
              true
            end
        end
    end
  prval () = TCPSocketConnection_addback_struct(pfat | tcp)
in
  ret
end

implement
tcp_socket_connection_receive (tcp) = let
  val is_connected = tcp_socket_connection_is_connected (tcp)
  val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
  val fd = socket_sock_fd (p->sock)
  val blocking = socket_blocking (p->sock)
  prval () = TCPSocketConnection_addback_struct(pfat | tcp)
in
  if (fd < 0) orelse (not is_connected) then None_vt () else let
      val b = if blocking then true else let
                val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
                val tout = socket_timeout (p->sock)
                val r = socket_wait_readable (p->sock, tout)
                prval () = TCPSocketConnection_addback_struct(pfat | tcp)
              in
                r
              end
    in
      None_vt () // xxx
    end
end

implement
tcp_socket_connection_close (tcp) = {
  val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
  val () = endpoint_close (p->endpoint)
  val () = socket_close (p->sock)
  val () = $UN.castvwtp0((pfat | p))
  val () = __free (tcp) where {
    extern fun __free {vt:vtype} (x: vt): void = "atspre_mfree_gc"
  }
}


More strong type

More strong type

#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 DELAY_MS 10.0

fun int_foreach_clo
  (n: natLt(256), f: &natLt(256) -<clo1> void): void = {
  val () = f n
  val () = if n > 0 then int_foreach_clo (n - 1, f)
}

implement main () = {
  fun fadein() = let
    var fwork = lam@ (n: natLt(256)) => {
      val () = analogWrite (LED, $UN.cast n)
      val () = delay_ms(DELAY_MS)
    }
  in
    int_foreach_clo(255, fwork)
  end // end of [fadein]
  val () = pinMode (LED, OUTPUT)
  val () = (fix f(): void => (fadein(); f()))()
}

#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 DELAY_MS 10.0

fun int_foreach_clo
  (n: int, f: &int -<clo1> void): void = {
  val () = f n
  val () = int_foreach_clo (n - 1, f)
}

implement main () = {
  fun fadein() = let
    var fwork = lam@ (n: int) => {
      val () = analogWrite (LED, $UN.cast n)
      val () = delay_ms(DELAY_MS)
    }
  in
    int_foreach_clo(256, fwork)
  end // end of [fadein]
  val () = pinMode (LED, OUTPUT)
  val () = (fix f(): void => (fadein(); f()))()
}


Updating: very minorly improving

Updating: very minorly improving

(*
** integer sets
*)

(* ****** ****** *)
//
staload
"./../SATS/intset.sats"
//
(* ****** ****** *)

assume
intset(n:int, xs:iset) = List0(int)

(* ****** ****** *)
//
implement
{}(*tmp*)
intset_nil() = list_nil()
//
implement
{}(*tmp*)
intset_int(x) = list_sing(x)
//
implement
{}(*tmp*)
intset_int2(x1, x2) = $list{int}(x1, x2)
//
implement
{}(*tmp*)
intset_int3(x1, x2, x3) = $list{int}(x1, x2, x3)
//
(* ****** ****** *)

implement
{}(*tmp*)
intset_ncomplement
  (xs, n) = let
//
fun
aux1
(
  i: int
, res: List0_vt(int)
) : List0_vt(int) =
(
//
if (i < n)
  then aux1(i+1, cons_vt(i, res)) else res
//
) (* end of [aux1] *)
//
and
aux2
(
  i: int
, x0: int
, xs: List0(int)
, res: List0_vt(int)
) : List0_vt(int) = (
//
if
(i < x0)
then (
  aux2(i+1, x0, xs, cons_vt(i, res))
) else (
  case+ xs of
  | list_nil() => aux1(i+1, res)
  | list_cons(x, xs) => aux2(i+1, x, xs, res)
) (* end of [else] *)
//
) (* end of [aux2] *)
//
val ys = (
//
case+ xs of
| list_nil() => aux1(0, nil_vt)
| list_cons(x, xs) => aux2(0, x, xs, nil_vt)
//
) : List0_vt(int)
//
in
  list_vt2t(list_vt_reverse(ys))
end // end of [intset_ncomplement]

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

implement
fprint_intset(out, xs) = fprint_list_sep(out, xs, "->")

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

(* end of [intset.dats] *)

(*
** integer sets
*)

(* ****** ****** *)
//
staload
"./../SATS/intset.sats"
//
(* ****** ****** *)

assume
intset(n:int, xs:iset) = List0(int)

(* ****** ****** *)
//
implement
{}(*tmp*)
intset_nil() = list_nil()
//
implement
{}(*tmp*)
intset_int(x) = list_sing(x)
//
implement
{}(*tmp*)
intset_int2(x1, x2) = $list{int}(x1, x2)
//
implement
{}(*tmp*)
intset_int3(x1, x2, x3) = $list{int}(x1, x2, x3)
//
(* ****** ****** *)

implement
{}(*tmp*)
intset_ncomplement
  (xs, n) = let
//
fun
aux1
(
  i: int
, res: List0_vt(int)
) : List0_vt(int) =
(
//
if (i < n)
  then aux1(i+1, cons_vt(i, res)) else res
//
) (* end of [aux1] *)
//
and
aux2
(
  i: int
, x0: int
, xs: List0(int)
, res: List0_vt(int)
) : List0_vt(int) = (
//
if
(i < x0)
then (
  aux2(i+1, x0, xs, cons_vt(i, res))
) else (
  case+ xs of
  | list_nil() => aux1(i+1, res)
  | list_cons(x, xs) => aux2(i+1, x, xs, res)
) (* end of [else] *)
//
) (* end of [aux2] *)
//
in
//
case+ xs of
| list_nil() =>
  list_vt2t(list_vt_reverse(aux1(0, nil_vt)))
| list_cons(x, xs) =>
  list_vt2t(list_vt_reverse(aux2(0, x, xs, nil_vt)))
//
end // end of [intset_ncomplement]

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

implement
fprint_intset(out, xs) = fprint_list_sep(out, xs, "->")

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

(* end of [intset.dats] *)


Updating location of jsmn.dats

Updating location of jsmn.dats

(*
** Parsing constraints in JSON format
*)

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

#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"

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

#define ATS_DYNLOADFLAG 0 (* no run-time dynloading *)

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

local
in
%{
#define JSMN_STRICT 1

#include "jsmn.c"
%}
end

local
in
#include "libats-/wdblair/jsmn/DATS/jsmn.dats"
end

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

(* end of [parsing_mylib.dats] *)

(*
** Parsing constraints in JSON format
*)

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

#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"

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

#define ATS_DYNLOADFLAG 0 (* no run-time dynloading *)

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

local
in
%{
#define JSMN_STRICT 1

#include "jsmn.c"
%}
end

local
in
#include "contrib/libats-/wdblair/jsmn/DATS/jsmn.dats"
end

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

(* end of [parsing_mylib.dats] *)


Updating: minorly improving

Updating: minorly improving

(*
** The M-N-K-game
*)

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

staload "./game.sats"

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

assume
board_type = mtrxszref (int)

(* ****** ****** *)
//
implement
board_make (m, n) =
  mtrxszref_make_elt<int> (i2sz(m), i2sz(n), 0)
//
(* ****** ****** *)

fun
pid2char (id: int): char =
(
case+ id of
| 0 => ' ' | 1 => 'X' | 2 => 'O' | _ => '#'
) (* end of [pid2char] *)

(* ****** ****** *)
//
implement
fprint_board (out, board) =
  fprint_mtrxszref_sep (out, board, "|", "\n")
//
(* ****** ****** *)

// (*
val () = // testing code
{
//
val () =
println! ("TESTING(game_board):")
//
val () =
println! ("TESTING(fprint_board): beg")
val board = board_make (3, 3)
val ((*void*)) = fprint_board (stdout_ref, board)
val ((*void*)) = fprint_newline (stdout_ref)
val () =
println! ("TESTING(fprint_board): end")
} (* end of [val] *)
// *)

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

(* end of [game_board.dats] *)

(*
** The M-N-K-game
*)

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

staload "./game.sats"

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

assume
board_type = mtrxszref (int)

(* ****** ****** *)
//
implement
board_make (m, n) =
  mtrxszref_make_elt<int> (i2sz(m), i2sz(n), 0)
//
(* ****** ****** *)

(* end of [game_board.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(* ****** ****** *)
//
// Trying libatscc2py/PYgame
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Starting time: May 23, 2016
//
(* ****** ****** *)
//
(*
#include
"share/atspre_define.hats"
*)
//
#include"./../../staloadall.hats"
//
(* ****** ****** *)
//
staload "./../../SATS/PYgame/pygame.sats"
//
(* ****** ****** *)
//
extern
fun
test01_main
(
// argless
) : void = "mac#"
//
implement
test01_main() =
{
//
val npnf = pygame_init_ret()
val ((*void*)) = println! ("np = ", npnf.0)
val ((*void*)) = println! ("nf = ", npnf.1)
//
val res = $tup(500,500)
val screen = display_set_mode(res)
val _(*Rect*) = screen.fill(Color(0, 0, 0))
//
val screen2 = Surface(screen.get_size(), SRCALPHA, 32)
//
(*
val () = println! ("screen2_width = ", screen2.get_width())
val () = println! ("screen2_height = ", screen2.get_height())
*)
//
val c1 = Color(200, 200, 200)
//
val r0 = Rect(100, 100, 300, 300)
//
val _rect_ = screen2.fill(c1, r0, 0)
//
val _rect_ =
  draw_circle(screen2, Color(0,0,0), $tup(250,250), 100)
//
val _rect_ =
  screen.blit(screen2, $tup(0, 0))
//
val ((*void*)) = display_flip((*void*))
//
val () = loop() where
{
  fun
  loop(): void = let
    val e = event_wait()
    val t = e.type()
  in
    ifcase
      | t = QUIT => ()
      | t = KEYDOWN => ()
      | _(*else*) => loop()
  end // end of [loop]
}
//
val ((*void*)) = pygame_quit((*void*))
//
} (* end of [test01_main] *)
//
(* ****** ****** *)

%{^
######
from libatscc2py_all import *
######
from ats2py_PYgame_pyame_cats import *
######
sys.setrecursionlimit(1000000)
######
%} // end of [%{^]

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

%{$
if __name__ == '__main__': test01_main()
%} // end of [%{$]

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

(* end of [test01.dats] *)

(* ****** ****** *)
//
// Trying libatscc2py/Pygame
//
(* ****** ****** *)
//
(*
#include
"share/atspre_define.hats"
*)
//
#include"./../../staloadall.hats"
//
(* ****** ****** *)
//
staload "./../../SATS/PYgame/pygame.sats"
//
(* ****** ****** *)
//
extern
fun
test01_main
(
// argless
) : void = "mac#"
//
implement
test01_main() =
{
//
val npnf = pygame_init_ret()
val ((*void*)) = println! ("np = ", npnf.0)
val ((*void*)) = println! ("nf = ", npnf.1)
//
val res = $tup(500,500)
val screen = display_set_mode(res)
val _(*Rect*) = screen.fill(Color(0, 0, 0))
//
val screen2 = Surface(screen.get_size(), SRCALPHA, 32)
//
(*
val () = println! ("screen2_width = ", screen2.get_width())
val () = println! ("screen2_height = ", screen2.get_height())
*)
//
val c1 = Color(200, 200, 200)
//
val r0 = Rect(100, 100, 300, 300)
//
val _rect_ = screen2.fill(c1, r0, 0)
//
val _rect_ =
  draw_circle(screen2, Color(0,0,0), $tup(250,250), 100)
//
val _rect_ =
  screen.blit(screen2, $tup(0, 0))
//
val ((*void*)) = display_flip((*void*))
//
val () = loop() where
{
  fun
  loop(): void = let
    val e = event_wait()
    val t = e.type()
  in
    ifcase
      | t = QUIT => ()
      | t = KEYDOWN => ()
      | _(*else*) => loop()
  end // end of [loop]
}
//
val ((*void*)) = pygame_quit((*void*))
//
} (* end of [test01_main] *)
//
(* ****** ****** *)

%{^
######
from libatscc2py_all import *
######
from ats2py_PYgame_pyame_cats import *
######
sys.setrecursionlimit(1000000)
######
%} // end of [%{^]

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

%{$
if __name__ == '__main__': test01_main()
%} // end of [%{$]

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

(* end of [test01.dats] *)