[bug disappearance] selection work now in 3D view, so we shut off the mouseup in it

the moving of matrix into the modeler fixed it ?
because i removed a matrix multiplication ?

@private type my_custom_shaderProgram = {
  program: Webgl.WebGLProgram;
  vertexPositionAttribute: Webgl.GLint;
  vertexNormalAttribute: Webgl.GLint;
  pMatrixUniform: Webgl.WebGLUniformLocation;
  mvMatrixUniform: Webgl.WebGLUniformLocation;
  nMatrixUniform: Webgl.WebGLUniformLocation;
  ambientColorUniform: Webgl.WebGLUniformLocation;
  lightingDirectionUniform: Webgl.WebGLUniformLocation;
  useLightingUniform: Webgl.WebGLUniformLocation
};

@private type static_buffer = {
  positions: Webgl.WebGLBuffer;
  itemSize: int; numItems: int;
  normals: Webgl.WebGLBuffer
};

@private type engine.scene = list(object);

@private type engine = {
  context: Webgl.Context.private;
  canvas: { selector:dom; width: int; height: int };
  shaderProgram: my_custom_shaderProgram
  static_buffers: { repcoords: { x:static_buffer; y:static_buffer; z:static_buffer } };
  framePickBuffer: Webgl.WebGLFramebuffer;
  scene: engine.scene;
  selector: dom;
  last_coord_fixer: option(Dom.dimensions -> vec3);
} ;

@client initPickBuffer(eng) =
  gl = eng.context;
  framePickBuffer = Webgl.createFramebuffer(gl);
  renderPickBuffer = Webgl.createRenderbuffer(gl);
  pickTexture = Webgl.createTexture(gl);
  do Webgl.bindTexture(gl, Webgl.TEXTURE_2D(gl), Option.some(pickTexture));
  tex = Webgl.Uint8Array.from_int_list([0, 0, 0]);
  do Webgl.texImage2D(gl, Webgl.TEXTURE_2D(gl), 0, Webgl.RGB(gl), eng.canvas.width, eng.canvas.height, 0, Webgl.RGB(gl), Webgl.UNSIGNED_BYTE(gl), Webgl.Uint8Array.to_ArrayBuffer(tex));
  do Webgl.bindFramebuffer(gl, Webgl.FRAMEBUFFER(gl), Option.some(framePickBuffer));
  do Webgl.bindRenderbuffer(gl, Webgl.RENDERBUFFER(gl), Option.some(renderPickBuffer));
  do Webgl.renderbufferStorage(gl, Webgl.RENDERBUFFER(gl), Webgl.DEPTH_COMPONENT16(gl), eng.canvas.width, eng.canvas.height);
  do Webgl.bindRenderbuffer(gl, Webgl.RENDERBUFFER(gl), Option.none);

  do Webgl.framebufferTexture2D(gl, Webgl.FRAMEBUFFER(gl), Webgl.COLOR_ATTACHMENT0(gl), Webgl.TEXTURE_2D(gl), pickTexture, 0);
  do Webgl.framebufferRenderbuffer(gl, Webgl.FRAMEBUFFER(gl), Webgl.DEPTH_ATTACHMENT(gl), Webgl.RENDERBUFFER(gl), renderPickBuffer);
  do Webgl.bindFramebuffer(gl, Webgl.FRAMEBUFFER(gl), Option.none);
  do Webgl.bindTexture(gl, Webgl.TEXTURE_2D(gl), Option.none);
  framePickBuffer
;

initShaders(gl) =
  f(e, str) =
    shader = Webgl.createShader(gl, e);
    do Webgl.shaderSource(gl, shader, str);
    do Webgl.compileShader(gl, shader);
    shader;
  fragmentShader = f(Webgl.FRAGMENT_SHADER(gl), CustomShaders.shader_fs);
  vertexShader = f(Webgl.VERTEX_SHADER(gl), CustomShaders.shader_vs);
  // TODO getShaderParameter
  shaderProgram = Webgl.createProgram(gl);
  do Webgl.attachShader(gl, shaderProgram, vertexShader);
  do Webgl.attachShader(gl, shaderProgram, fragmentShader);
  do Webgl.linkProgram(gl, shaderProgram);
  // TODO : getProgramParameter(shaderProgram, gl.LINK_STATUS)) {
  do Webgl.useProgram(gl, shaderProgram);
  shaderProgram =
    vertexPositionAttribute = Webgl.getAttribLocation(gl, shaderProgram, "aVertexPosition");
    vertexNormalAttribute = Webgl.getAttribLocation(gl, shaderProgram, "aVertexNormal");
    do Webgl.enableVertexAttribArray(gl, vertexPositionAttribute);
    do Webgl.enableVertexAttribArray(gl, vertexNormalAttribute);
    { program = shaderProgram;
      ~vertexPositionAttribute;
      ~vertexNormalAttribute;
      pMatrixUniform = Webgl.getUniformLocation(gl, shaderProgram, "uPMatrix");
      mvMatrixUniform = Webgl.getUniformLocation(gl, shaderProgram, "uMVMatrix");
      nMatrixUniform = Webgl.getUniformLocation(gl, shaderProgram, "uNMatrix");
      ambientColorUniform = Webgl.getUniformLocation(gl, shaderProgram, "uAmbientColor");
      lightingDirectionUniform = Webgl.getUniformLocation(gl, shaderProgram, "uLightingDirection");
      useLightingUniform = Webgl.getUniformLocation(gl, shaderProgram, "uUseLighting");
    };
  shaderProgram
;

initLineXBuffers(gl, orient) =
  (vertices, vertexNormals) = match orient with
    | {x} -> ([ 0.0, 0.0, 0.0, 5.0, 0.0, 0.0 ], [ 2.5, 0.0, 0.0,        2.5, -1.0, 0.0 ])
    | {y} -> ([ 0.0, 0.0, 0.0, 0.0, 5.0, 0.0 ], [ 0.0, 2.5, 0.0,        -1.0, 2.5, 0.0 ])
    | {z} -> ([ 0.0, 0.0, 0.0, 0.0, 0.0, 5.0 ], [ 0.0, 0.0, 2.5,        0.0, -1.0, 2.5 ])
    end ;
  vertexPositionBuffer = Webgl.createBuffer(gl);
  do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), vertexPositionBuffer);
  do Webgl.bufferData(gl, Webgl.ARRAY_BUFFER(gl),
    Webgl.Float32Array.to_ArrayBuffer(Webgl.Float32Array.from_float_list(vertices)),
    Webgl.STATIC_DRAW(gl));
  vertexNormalBuffer = Webgl.createBuffer(gl);
  do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), vertexNormalBuffer);
  do Webgl.bufferData(gl, Webgl.ARRAY_BUFFER(gl),
    Webgl.Float32Array.to_ArrayBuffer(Webgl.Float32Array.from_float_list(vertexNormals)),
    Webgl.STATIC_DRAW(gl));
  { positions=vertexPositionBuffer; itemSize=3; numItems=2; normals=vertexNormalBuffer }
;

setMatrixUniforms(gl, shaderProgram, pMatrix, mvMatrix) =
  a =
    b = mat4.to_list(pMatrix);
    c = Webgl.Float32Array.from_float_list(b);
    c;
  e =
    f = mat4.to_list(mvMatrix);
    g = Webgl.Float32Array.from_float_list(f);
    g;
  do Webgl.uniformMatrix4fv(gl, shaderProgram.pMatrixUniform, false, a);
  do Webgl.uniformMatrix4fv(gl, shaderProgram.mvMatrixUniform, false, e);
  normalMatrix = mat3.create();
  do mat4.toInverseMat3(mvMatrix, normalMatrix);
  do mat3.transpose(normalMatrix, normalMatrix);
  do Webgl.uniformMatrix3fv(gl, shaderProgram.nMatrixUniform, false, Webgl.Float32Array.from_float_list(mat3.to_list(normalMatrix)));
  void
;

setup_boxes(eng) =
  cnf_x(pos) = { pos with f1=0.0 }; cnf_y(pos) = { pos with f2=0.0 }; cnf_z(pos) = { pos with f3=0.0 };
  g(x:int, y:int, w:int, h:int, clear_near_far) =
    inbox(pos) = (pos.x_px >= x) && (pos.y_px >= y) && (pos.x_px < (w + x)) && (pos.y_px < (h + y));
    { ~x; ~y; ~w; ~h; ~inbox; ~clear_near_far } ;
  compute_left_right(x) = if ((mod(x, 2)) == 0) then
      a = (x / 2);
      ((a, a), 0)
    else
      b = (x / 2);
      ((b, b+1), 0);
  ((w_l, w_r), e_w) = compute_left_right(eng.canvas.width);
  ((h_u, h_d), e_h) = compute_left_right(eng.canvas.height);
  { _YX=g(0, h_d+e_h, w_l, h_u, cnf_z); _YZ=g(w_l+e_w, h_d+e_h, w_r, h_u, cnf_x);
    _ZX=g(0, 0, w_l, h_d, cnf_y);       _3D=g(w_l+e_w, 0, w_r, h_d, cnf_y) }
;

which_box(b, pos) =
  if b._YX.inbox(pos) then {_YX}
  else if b._YZ.inbox(pos) then {_YZ}
  else if b._ZX.inbox(pos) then {_ZX}
  else if b._3D.inbox(pos) then {_3D}
  else {out}
;

fetch_box(b, who) = match who with
  | {_YX} -> b._YX
  | {_YZ} -> b._YZ
  | {_ZX} -> b._ZX
  | {_3D} -> b._3D
  end ;

compute_an_eye_into_ortho(mat, cs, clear_near_far) =
  do mat4.translate(mat, vec3.from_public(cs.target), mat);
  tmp =
    h = cs.eye.f3;
    clear_near_far((h, h, h));
  _ = mat4.scale(mat, vec3.from_public(tmp), mat);
  mat ;

drawScene_for_a_viewport(eng, who, viewport, camera_setting : mat4, up, scene, mode) =
  gl = eng.context; shaderProgram = eng.shaderProgram; repcoords = eng.static_buffers.repcoords;
  do Webgl.viewport(gl, viewport.x, viewport.y, viewport.w, viewport.h);
  pMatrix = camera_setting;
  mvMatrix =
    tmp_mvMatrix = mat4.create();
    do mat4.identity(tmp_mvMatrix);
    Stack.push(Stack.create(), tmp_mvMatrix);
  do setMatrixUniforms(gl, shaderProgram, pMatrix, Stack.peek(mvMatrix));
  draw_rep(r, g, b, rep) =
    do Webgl.uniform3f(gl, shaderProgram.ambientColorUniform, r, g, b);
    do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), rep.positions);
    do Webgl.vertexAttribPointer(gl, shaderProgram.vertexPositionAttribute, rep.itemSize, Webgl.FLOAT(gl), false, 0, 0);
    do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), rep.normals);
    do Webgl.vertexAttribPointer(gl, shaderProgram.vertexNormalAttribute, rep.itemSize, Webgl.FLOAT(gl), false, 0, 0);
    do Webgl.drawArrays(gl, Webgl.LINES(gl), 0, rep.numItems);
    void ;

  _ =
    match mode with
    | {normal} ->
      do Webgl.uniform1i(gl, shaderProgram.useLightingUniform, 0); // 0 = false
      do draw_rep(1.0, 0.0, 0.0, repcoords.x);
      do draw_rep(0.0, 1.0, 0.0, repcoords.y);
      do draw_rep(0.0, 0.0, 1.0, repcoords.z);
      do match who with
        | {_3D} ->
          do Webgl.uniform1i(gl, shaderProgram.useLightingUniform, 1); // 1 = true
          Webgl.uniform3f(gl, shaderProgram.lightingDirectionUniform, 0.85, 0.8, 0.75)
        | _ -> void end;
      List.iter((object -> display(eng, pMatrix, mvMatrix, object, false)), scene)
    | {pick} ->
      do Webgl.bindFramebuffer(gl, Webgl.FRAMEBUFFER(gl), Option.some(eng.framePickBuffer));
      do Webgl.clear(gl, Webgl.GLbitfield_OR(Webgl.COLOR_BUFFER_BIT(gl), Webgl.DEPTH_BUFFER_BIT(gl)));
      do Webgl.uniform1i(gl, shaderProgram.useLightingUniform, 0); // 0 = false;
      do List.iter((object -> display(eng, pMatrix, mvMatrix, object, true)), scene);
      void
    end ;

  (pMatrix, mvMatrix)
;

@private drawScene_and_register(org_eng, get_scene : (->Scene.Client.scene), get_camera_setting : (->Modeler.views), get_mode, get_pending_mouseup_and_clean) =
  viewbox = setup_boxes(org_eng) ;
  last_viewbox = Mutable.make(Option.none);
  rec aux(eng:engine) =
    gl = eng.context;
    (eng, scene) =
      f(is_selected, p) =
        match List.find((z_in_mem -> z_in_mem.id == p.id), eng.scene) with
        | { some=in_mem } -> { in_mem with position=p.cube; ~is_selected; color=p.color }
        | { none } -> Cube.create(gl, p, is_selected)
        end;
      scene : engine.scene =
        tmp = get_scene();
        others_scene = List.map(f(false, _), tmp.others.objs);
        selection_scene = Option.switch((the -> [ f(true, the) ]), List.empty, tmp.selection);
        List.append(selection_scene, others_scene);
      ({ eng with ~scene }, scene);
    views = get_camera_setting();
    eng =
      match get_mode() with
      | {pick=pos; ~cont} -> (
        match which_box(viewbox, pos) with
        | {out} -> eng
        | {_YX} as who | {_YZ} as who | {_ZX} as who | {_3D} as who ->
          //do Log.debug("Picking", "in box: '{who}' \t {viewbox}");
          this_viewbox = fetch_box(viewbox, who);
          _ = drawScene_for_a_viewport(eng, who, this_viewbox, fetch_box(views, who), (0.0, 1.0, 0.0), scene, {pick});
          mvMatrix = mat4.copy(fetch_box(get_camera_setting(), who)) ;
          do mat4.inverse(mvMatrix, mvMatrix);
          g(pos : Dom.dimensions) : vec3 =
            x = (float_of_int(pos.x_px - this_viewbox.x) / float_of_int(this_viewbox.w)) * 2.0 - 1.0;
            y = (float_of_int(pos.y_px - this_viewbox.y) / float_of_int(this_viewbox.h)) * 2.0 - 1.0;
            vstart = vec4.from_public((x, y, 1.0, 1.0));
            vtmp = vec4.from_public((9.9, 9.9, 9.9, 9.9));
            do mat4.multiplyVec4(mvMatrix, vstart, vtmp);
            vpreres = vec4.to_public(vtmp);
            vres = (vpreres.f1 / vpreres.f4, vpreres.f2 / vpreres.f4, vpreres.f3 / vpreres.f4);
            do Log.debug("Converting coord", "vstart={ vec4.str(vstart) }, \t vres={ vres }");
            vres;
          pos_result = g(pos);
          possible_target =
            pickedColor =
              data = Webgl.Uint8Array.from_int_list(List.init((_->123), 4));
              do Webgl.readPixels(gl, pos.x_px, pos.y_px, 1, 1, Webgl.RGBA(gl), Webgl.UNSIGNED_BYTE(gl), Webgl.Uint8Array.to_ArrayBuffer(data));
              match Webgl.Uint8Array.to_int_list(data) with
              | [r, g, b, _] -> (r, g, b)
              | _ -> error("Picking failure")
              end ;
            do Log.debug("Picking", "Color is: { pickedColor }");
            f =
              (r, g, b) = pickedColor;
              (z -> (z.picking_color == (float_of_int(r) / 255., float_of_int(g) / 255., float_of_int(b) / 255.))) ;
            Option.map((u -> u.id), List.find(f, eng.scene));
          do Webgl.bindFramebuffer(gl, Webgl.FRAMEBUFFER(gl), Option.none);
          _ = cont({ mousedown; pos=this_viewbox.clear_near_far(pos_result); ~possible_target; coord_fixer=Option.some(g) });
          do last_viewbox.set(Option.some((this_viewbox, who)));
          { eng with last_coord_fixer=Option.some(g) }
        end)
      | {normal} ->
        do Webgl.clear(gl, Webgl.GLbitfield_OR(Webgl.COLOR_BUFFER_BIT(gl), Webgl.DEPTH_BUFFER_BIT(gl)));
        _ = drawScene_for_a_viewport(eng, {_YX}, viewbox._YX, views._YX, (0.0, 1.0, 0.0), scene, {normal});
        _ = drawScene_for_a_viewport(eng, {_YZ}, viewbox._YZ, views._YZ, (0.0, 1.0, 0.0), scene, {normal});
        _ = drawScene_for_a_viewport(eng, {_ZX}, viewbox._ZX, views._ZX, (0.0, 0.0, 1.0), scene, {normal});
        _ = drawScene_for_a_viewport(eng, {_3D}, viewbox._3D, views._3D, (0.0, 1.0, 0.0), scene, {normal});
        eng
      end ;
    do
      todo : list = get_pending_mouseup_and_clean();
      f((bad_pos, cont)) : void =
        g(last_coord_fixer) =
          with_v((this_viewbox, this_who)) =
            match this_who with
            | {out} | {_3D} -> void
            | _ ->
              if this_viewbox.inbox(bad_pos) then
                cont(this_viewbox.clear_near_far(last_coord_fixer(bad_pos)))
              else
                Log.warning("Incorrect mouseup", "at bad_pos={bad_pos}")
            end;
          Option.iter(with_v, last_viewbox.get());
        Option.iter(g, eng.last_coord_fixer);
      List.iter(f, todo);
    do RequestAnimationFrame.request((_ -> aux(eng)), eng.selector);
    void
    ;
  aux(org_eng)
;

initGL(canvas_sel, width, height, get_scene, get_camera_setting, mouse_listener) : outcome =
  match WebGLUtils.setupWebGL_with_custom_failure(Dom.of_selection(canvas_sel)) with
  | { ok=context } ->
    mode = Mutable.make({normal});
    pending_mouseup = Mutable.make(List.empty);
    is_picking(m) = match m with | { pick=_; cont=_ } -> true | _ -> false end;
    _ =
      recompute_pos(rel_mouse_position_on_page) =
        m_pos = // we transform the pos to be relative to the upper leftcorner of the canvas
          c_pos = Dom.get_offset(canvas_sel);
          rel = rel_mouse_position_on_page;
          { x_px=max(rel.x_px - c_pos.x_px, 0); y_px=max(rel.y_px - c_pos.y_px, 0) };
        // now with gl the origin will be at the lower left corner
        gl_pos = { x_px=min(max(m_pos.x_px,0), width-1); y_px=min(max(height - 1 - m_pos.y_px, 0), height-1) };
        do Log.debug("P", "[({m_pos.x_px},{m_pos.y_px})] {gl_pos.x_px}, {gl_pos.y_px}");
        gl_pos;
      handler_mousedown(e) =
        gl_pos = recompute_pos(e.mouse_position_on_page);
        cont(e) =
          do mode.set({normal});
          mouse_listener(e);
        if not(is_picking(mode.get())) then mode.set({pick=gl_pos; ~cont}) else void;
      _ = Dom.bind(canvas_sel, { mousedown }, handler_mousedown);
      handler_mouseup(e) =
        gl_pos = recompute_pos(e.mouse_position_on_page);
        cont(x) = mouse_listener({mouseup; pos=x});
        pending_mouseup.set(List.cons((gl_pos, cont), pending_mouseup.get()));
      _ = Dom.bind(canvas_sel, { mouseup }, handler_mouseup);
      void;
    gl = context;
    eng : engine =
      start = @openrecord({ context=gl; canvas={ selector=canvas_sel; ~width; ~height }; scene=List.empty; selector=canvas_sel;
        last_coord_fixer=Option.none });
      start = { start with shaderProgram=initShaders(gl) };
      start = { start with framePickBuffer=initPickBuffer(start) } ;
      { start with static_buffers.repcoords=
        { x=initLineXBuffers(gl, {x}); y=initLineXBuffers(gl, {y}); z=initLineXBuffers(gl, {z}) } };
    //Clear screen and make everything light gray // disabled to show png grid
    //do Webgl.clearColor(gl, 0.875, 0.875, 0.875, 1.0);
    //we should do depth testing so that things drawn behind other
    //things should be hidden by the things in front of them).
    do Webgl.clearDepth(gl, 1.0);
    do Webgl.enable(gl, Webgl.DEPTH_TEST(gl));
    do Webgl.depthFunc(gl, Webgl.LEQUAL(gl));
    do
      get_pending_mouseup_and_clean() =
        tmp = List.rev(pending_mouseup.get());
        do pending_mouseup.set(List.empty);
        tmp;
      drawScene_and_register(eng, get_scene, get_camera_setting, mode.get, get_pending_mouseup_and_clean);
    { success }
  | { ~ko } -> { failure=ko }
  end ;

@private type my_custom_shaderProgram = {
  program: Webgl.WebGLProgram;
  vertexPositionAttribute: Webgl.GLint;
  vertexNormalAttribute: Webgl.GLint;
  pMatrixUniform: Webgl.WebGLUniformLocation;
  mvMatrixUniform: Webgl.WebGLUniformLocation;
  nMatrixUniform: Webgl.WebGLUniformLocation;
  ambientColorUniform: Webgl.WebGLUniformLocation;
  lightingDirectionUniform: Webgl.WebGLUniformLocation;
  useLightingUniform: Webgl.WebGLUniformLocation
};

@private type static_buffer = {
  positions: Webgl.WebGLBuffer;
  itemSize: int; numItems: int;
  normals: Webgl.WebGLBuffer
};

@private type engine.scene = list(object);

@private type engine = {
  context: Webgl.Context.private;
  canvas: { selector:dom; width: int; height: int };
  shaderProgram: my_custom_shaderProgram
  static_buffers: { repcoords: { x:static_buffer; y:static_buffer; z:static_buffer } };
  framePickBuffer: Webgl.WebGLFramebuffer;
  scene: engine.scene;
  selector: dom;
  last_coord_fixer: option(Dom.dimensions -> vec3);
} ;

@client initPickBuffer(eng) =
  gl = eng.context;
  framePickBuffer = Webgl.createFramebuffer(gl);
  renderPickBuffer = Webgl.createRenderbuffer(gl);
  pickTexture = Webgl.createTexture(gl);
  do Webgl.bindTexture(gl, Webgl.TEXTURE_2D(gl), Option.some(pickTexture));
  tex = Webgl.Uint8Array.from_int_list([0, 0, 0]);
  do Webgl.texImage2D(gl, Webgl.TEXTURE_2D(gl), 0, Webgl.RGB(gl), eng.canvas.width, eng.canvas.height, 0, Webgl.RGB(gl), Webgl.UNSIGNED_BYTE(gl), Webgl.Uint8Array.to_ArrayBuffer(tex));
  do Webgl.bindFramebuffer(gl, Webgl.FRAMEBUFFER(gl), Option.some(framePickBuffer));
  do Webgl.bindRenderbuffer(gl, Webgl.RENDERBUFFER(gl), Option.some(renderPickBuffer));
  do Webgl.renderbufferStorage(gl, Webgl.RENDERBUFFER(gl), Webgl.DEPTH_COMPONENT16(gl), eng.canvas.width, eng.canvas.height);
  do Webgl.bindRenderbuffer(gl, Webgl.RENDERBUFFER(gl), Option.none);

  do Webgl.framebufferTexture2D(gl, Webgl.FRAMEBUFFER(gl), Webgl.COLOR_ATTACHMENT0(gl), Webgl.TEXTURE_2D(gl), pickTexture, 0);
  do Webgl.framebufferRenderbuffer(gl, Webgl.FRAMEBUFFER(gl), Webgl.DEPTH_ATTACHMENT(gl), Webgl.RENDERBUFFER(gl), renderPickBuffer);
  do Webgl.bindFramebuffer(gl, Webgl.FRAMEBUFFER(gl), Option.none);
  do Webgl.bindTexture(gl, Webgl.TEXTURE_2D(gl), Option.none);
  framePickBuffer
;

initShaders(gl) =
  f(e, str) =
    shader = Webgl.createShader(gl, e);
    do Webgl.shaderSource(gl, shader, str);
    do Webgl.compileShader(gl, shader);
    shader;
  fragmentShader = f(Webgl.FRAGMENT_SHADER(gl), CustomShaders.shader_fs);
  vertexShader = f(Webgl.VERTEX_SHADER(gl), CustomShaders.shader_vs);
  // TODO getShaderParameter
  shaderProgram = Webgl.createProgram(gl);
  do Webgl.attachShader(gl, shaderProgram, vertexShader);
  do Webgl.attachShader(gl, shaderProgram, fragmentShader);
  do Webgl.linkProgram(gl, shaderProgram);
  // TODO : getProgramParameter(shaderProgram, gl.LINK_STATUS)) {
  do Webgl.useProgram(gl, shaderProgram);
  shaderProgram =
    vertexPositionAttribute = Webgl.getAttribLocation(gl, shaderProgram, "aVertexPosition");
    vertexNormalAttribute = Webgl.getAttribLocation(gl, shaderProgram, "aVertexNormal");
    do Webgl.enableVertexAttribArray(gl, vertexPositionAttribute);
    do Webgl.enableVertexAttribArray(gl, vertexNormalAttribute);
    { program = shaderProgram;
      ~vertexPositionAttribute;
      ~vertexNormalAttribute;
      pMatrixUniform = Webgl.getUniformLocation(gl, shaderProgram, "uPMatrix");
      mvMatrixUniform = Webgl.getUniformLocation(gl, shaderProgram, "uMVMatrix");
      nMatrixUniform = Webgl.getUniformLocation(gl, shaderProgram, "uNMatrix");
      ambientColorUniform = Webgl.getUniformLocation(gl, shaderProgram, "uAmbientColor");
      lightingDirectionUniform = Webgl.getUniformLocation(gl, shaderProgram, "uLightingDirection");
      useLightingUniform = Webgl.getUniformLocation(gl, shaderProgram, "uUseLighting");
    };
  shaderProgram
;

initLineXBuffers(gl, orient) =
  (vertices, vertexNormals) = match orient with
    | {x} -> ([ 0.0, 0.0, 0.0, 5.0, 0.0, 0.0 ], [ 2.5, 0.0, 0.0,        2.5, -1.0, 0.0 ])
    | {y} -> ([ 0.0, 0.0, 0.0, 0.0, 5.0, 0.0 ], [ 0.0, 2.5, 0.0,        -1.0, 2.5, 0.0 ])
    | {z} -> ([ 0.0, 0.0, 0.0, 0.0, 0.0, 5.0 ], [ 0.0, 0.0, 2.5,        0.0, -1.0, 2.5 ])
    end ;
  vertexPositionBuffer = Webgl.createBuffer(gl);
  do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), vertexPositionBuffer);
  do Webgl.bufferData(gl, Webgl.ARRAY_BUFFER(gl),
    Webgl.Float32Array.to_ArrayBuffer(Webgl.Float32Array.from_float_list(vertices)),
    Webgl.STATIC_DRAW(gl));
  vertexNormalBuffer = Webgl.createBuffer(gl);
  do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), vertexNormalBuffer);
  do Webgl.bufferData(gl, Webgl.ARRAY_BUFFER(gl),
    Webgl.Float32Array.to_ArrayBuffer(Webgl.Float32Array.from_float_list(vertexNormals)),
    Webgl.STATIC_DRAW(gl));
  { positions=vertexPositionBuffer; itemSize=3; numItems=2; normals=vertexNormalBuffer }
;

setMatrixUniforms(gl, shaderProgram, pMatrix, mvMatrix) =
  a =
    b = mat4.to_list(pMatrix);
    c = Webgl.Float32Array.from_float_list(b);
    c;
  e =
    f = mat4.to_list(mvMatrix);
    g = Webgl.Float32Array.from_float_list(f);
    g;
  do Webgl.uniformMatrix4fv(gl, shaderProgram.pMatrixUniform, false, a);
  do Webgl.uniformMatrix4fv(gl, shaderProgram.mvMatrixUniform, false, e);
  normalMatrix = mat3.create();
  do mat4.toInverseMat3(mvMatrix, normalMatrix);
  do mat3.transpose(normalMatrix, normalMatrix);
  do Webgl.uniformMatrix3fv(gl, shaderProgram.nMatrixUniform, false, Webgl.Float32Array.from_float_list(mat3.to_list(normalMatrix)));
  void
;

setup_boxes(eng) =
  cnf_x(pos) = { pos with f1=0.0 }; cnf_y(pos) = { pos with f2=0.0 }; cnf_z(pos) = { pos with f3=0.0 };
  g(x:int, y:int, w:int, h:int, clear_near_far) =
    inbox(pos) = (pos.x_px >= x) && (pos.y_px >= y) && (pos.x_px < (w + x)) && (pos.y_px < (h + y));
    { ~x; ~y; ~w; ~h; ~inbox; ~clear_near_far } ;
  compute_left_right(x) = if ((mod(x, 2)) == 0) then
      a = (x / 2);
      ((a, a), 0)
    else
      b = (x / 2);
      ((b, b+1), 0);
  ((w_l, w_r), e_w) = compute_left_right(eng.canvas.width);
  ((h_u, h_d), e_h) = compute_left_right(eng.canvas.height);
  { _YX=g(0, h_d+e_h, w_l, h_u, cnf_z); _YZ=g(w_l+e_w, h_d+e_h, w_r, h_u, cnf_x);
    _ZX=g(0, 0, w_l, h_d, cnf_y);       _3D=g(w_l+e_w, 0, w_r, h_d, cnf_y) }
;

which_box(b, pos) =
  if b._YX.inbox(pos) then {_YX}
  else if b._YZ.inbox(pos) then {_YZ}
  else if b._ZX.inbox(pos) then {_ZX}
  else if b._3D.inbox(pos) then {_3D}
  else {out}
;

fetch_box(b, who) = match who with
  | {_YX} -> b._YX
  | {_YZ} -> b._YZ
  | {_ZX} -> b._ZX
  | {_3D} -> b._3D
  end ;

compute_an_eye_into_ortho(mat, cs, clear_near_far) =
  do mat4.translate(mat, vec3.from_public(cs.target), mat);
  tmp =
    h = cs.eye.f3;
    clear_near_far((h, h, h));
  _ = mat4.scale(mat, vec3.from_public(tmp), mat);
  mat ;

drawScene_for_a_viewport(eng, who, viewport, camera_setting : mat4, up, scene, mode) =
  gl = eng.context; shaderProgram = eng.shaderProgram; repcoords = eng.static_buffers.repcoords;
  do Webgl.viewport(gl, viewport.x, viewport.y, viewport.w, viewport.h);
  pMatrix = camera_setting;
  mvMatrix =
    tmp_mvMatrix = mat4.create();
    do mat4.identity(tmp_mvMatrix);
    Stack.push(Stack.create(), tmp_mvMatrix);
  do setMatrixUniforms(gl, shaderProgram, pMatrix, Stack.peek(mvMatrix));
  draw_rep(r, g, b, rep) =
    do Webgl.uniform3f(gl, shaderProgram.ambientColorUniform, r, g, b);
    do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), rep.positions);
    do Webgl.vertexAttribPointer(gl, shaderProgram.vertexPositionAttribute, rep.itemSize, Webgl.FLOAT(gl), false, 0, 0);
    do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), rep.normals);
    do Webgl.vertexAttribPointer(gl, shaderProgram.vertexNormalAttribute, rep.itemSize, Webgl.FLOAT(gl), false, 0, 0);
    do Webgl.drawArrays(gl, Webgl.LINES(gl), 0, rep.numItems);
    void ;

  _ =
    match mode with
    | {normal} ->
      do Webgl.uniform1i(gl, shaderProgram.useLightingUniform, 0); // 0 = false
      do draw_rep(1.0, 0.0, 0.0, repcoords.x);
      do draw_rep(0.0, 1.0, 0.0, repcoords.y);
      do draw_rep(0.0, 0.0, 1.0, repcoords.z);
      do match who with
        | {_3D} ->
          do Webgl.uniform1i(gl, shaderProgram.useLightingUniform, 1); // 1 = true
          Webgl.uniform3f(gl, shaderProgram.lightingDirectionUniform, 0.85, 0.8, 0.75)
        | _ -> void end;
      List.iter((object -> display(eng, pMatrix, mvMatrix, object, false)), scene)
    | {pick} ->
      do Webgl.bindFramebuffer(gl, Webgl.FRAMEBUFFER(gl), Option.some(eng.framePickBuffer));
      do Webgl.clear(gl, Webgl.GLbitfield_OR(Webgl.COLOR_BUFFER_BIT(gl), Webgl.DEPTH_BUFFER_BIT(gl)));
      do Webgl.uniform1i(gl, shaderProgram.useLightingUniform, 0); // 0 = false;
      do List.iter((object -> display(eng, pMatrix, mvMatrix, object, true)), scene);
      void
    end ;

  (pMatrix, mvMatrix)
;

@private drawScene_and_register(org_eng, get_scene : (->Scene.Client.scene), get_camera_setting : (->Modeler.views), get_mode, get_pending_mouseup_and_clean) =
  viewbox = setup_boxes(org_eng) ;
  last_viewbox = Mutable.make(Option.none);
  rec aux(eng:engine) =
    gl = eng.context;
    (eng, scene) =
      f(is_selected, p) =
        match List.find((z_in_mem -> z_in_mem.id == p.id), eng.scene) with
        | { some=in_mem } -> { in_mem with position=p.cube; ~is_selected; color=p.color }
        | { none } -> Cube.create(gl, p, is_selected)
        end;
      scene : engine.scene =
        tmp = get_scene();
        others_scene = List.map(f(false, _), tmp.others.objs);
        selection_scene = Option.switch((the -> [ f(true, the) ]), List.empty, tmp.selection);
        List.append(selection_scene, others_scene);
      ({ eng with ~scene }, scene);
    views = get_camera_setting();
    eng =
      match get_mode() with
      | {pick=pos; ~cont} -> (
        match which_box(viewbox, pos) with
        | {out} -> eng
        | {_YX} as who | {_YZ} as who | {_ZX} as who | {_3D} as who ->
          //do Log.debug("Picking", "in box: '{who}' \t {viewbox}");
          this_viewbox = fetch_box(viewbox, who);
          _ = drawScene_for_a_viewport(eng, who, this_viewbox, fetch_box(views, who), (0.0, 1.0, 0.0), scene, {pick});
          mvMatrix = mat4.copy(fetch_box(get_camera_setting(), who)) ;
          do mat4.inverse(mvMatrix, mvMatrix);
          g(pos : Dom.dimensions) : vec3 =
            x = (float_of_int(pos.x_px - this_viewbox.x) / float_of_int(this_viewbox.w)) * 2.0 - 1.0;
            y = (float_of_int(pos.y_px - this_viewbox.y) / float_of_int(this_viewbox.h)) * 2.0 - 1.0;
            vstart = vec4.from_public((x, y, 1.0, 1.0));
            vtmp = vec4.from_public((9.9, 9.9, 9.9, 9.9));
            do mat4.multiplyVec4(mvMatrix, vstart, vtmp);
            vpreres = vec4.to_public(vtmp);
            vres = (vpreres.f1 / vpreres.f4, vpreres.f2 / vpreres.f4, vpreres.f3 / vpreres.f4);
            do Log.debug("Converting coord", "vstart={ vec4.str(vstart) }, \t vres={ vres }");
            vres;
          pos_result = g(pos);
          possible_target =
            pickedColor =
              data = Webgl.Uint8Array.from_int_list(List.init((_->123), 4));
              do Webgl.readPixels(gl, pos.x_px, pos.y_px, 1, 1, Webgl.RGBA(gl), Webgl.UNSIGNED_BYTE(gl), Webgl.Uint8Array.to_ArrayBuffer(data));
              match Webgl.Uint8Array.to_int_list(data) with
              | [r, g, b, _] -> (r, g, b)
              | _ -> error("Picking failure")
              end ;
            do Log.debug("Picking", "Color is: { pickedColor }");
            f =
              (r, g, b) = pickedColor;
              (z -> (z.picking_color == (float_of_int(r) / 255., float_of_int(g) / 255., float_of_int(b) / 255.))) ;
            Option.map((u -> u.id), List.find(f, eng.scene));
          do Webgl.bindFramebuffer(gl, Webgl.FRAMEBUFFER(gl), Option.none);
          _ = cont({ mousedown; pos=this_viewbox.clear_near_far(pos_result); ~possible_target; coord_fixer=Option.some(g) });
          do last_viewbox.set(Option.some(this_viewbox));
          { eng with last_coord_fixer=Option.some(g) }
        end)
      | {normal} ->
        do Webgl.clear(gl, Webgl.GLbitfield_OR(Webgl.COLOR_BUFFER_BIT(gl), Webgl.DEPTH_BUFFER_BIT(gl)));
        _ = drawScene_for_a_viewport(eng, {_YX}, viewbox._YX, views._YX, (0.0, 1.0, 0.0), scene, {normal});
        _ = drawScene_for_a_viewport(eng, {_YZ}, viewbox._YZ, views._YZ, (0.0, 1.0, 0.0), scene, {normal});
        _ = drawScene_for_a_viewport(eng, {_ZX}, viewbox._ZX, views._ZX, (0.0, 0.0, 1.0), scene, {normal});
        _ = drawScene_for_a_viewport(eng, {_3D}, viewbox._3D, views._3D, (0.0, 1.0, 0.0), scene, {normal});
        eng
      end ;
    do
      todo : list = get_pending_mouseup_and_clean();
      f((bad_pos, cont)) : void =
        g(last_coord_fixer) =
          with_v(this_viewbox) =
            if this_viewbox.inbox(bad_pos) then
              cont(this_viewbox.clear_near_far(last_coord_fixer(bad_pos)))
            else
              Log.warning("Incorrect mouseup", "at bad_pos={bad_pos}");
          Option.iter(with_v, last_viewbox.get());
        Option.iter(g, eng.last_coord_fixer);
      List.iter(f, todo);
    do RequestAnimationFrame.request((_ -> aux(eng)), eng.selector);
    void
    ;
  aux(org_eng)
;

initGL(canvas_sel, width, height, get_scene, get_camera_setting, mouse_listener) : outcome =
  match WebGLUtils.setupWebGL_with_custom_failure(Dom.of_selection(canvas_sel)) with
  | { ok=context } ->
    mode = Mutable.make({normal});
    pending_mouseup = Mutable.make(List.empty);
    is_picking(m) = match m with | { pick=_; cont=_ } -> true | _ -> false end;
    _ =
      recompute_pos(rel_mouse_position_on_page) =
        m_pos = // we transform the pos to be relative to the upper leftcorner of the canvas
          c_pos = Dom.get_offset(canvas_sel);
          rel = rel_mouse_position_on_page;
          { x_px=max(rel.x_px - c_pos.x_px, 0); y_px=max(rel.y_px - c_pos.y_px, 0) };
        // now with gl the origin will be at the lower left corner
        gl_pos = { x_px=min(max(m_pos.x_px,0), width-1); y_px=min(max(height - 1 - m_pos.y_px, 0), height-1) };
        do Log.debug("P", "[({m_pos.x_px},{m_pos.y_px})] {gl_pos.x_px}, {gl_pos.y_px}");
        gl_pos;
      handler_mousedown(e) =
        gl_pos = recompute_pos(e.mouse_position_on_page);
        cont(e) =
          do mode.set({normal});
          mouse_listener(e);
        if not(is_picking(mode.get())) then mode.set({pick=gl_pos; ~cont}) else void;
      _ = Dom.bind(canvas_sel, { mousedown }, handler_mousedown);
      handler_mouseup(e) =
        gl_pos = recompute_pos(e.mouse_position_on_page);
        cont(x) = mouse_listener({mouseup; pos=x});
        pending_mouseup.set(List.cons((gl_pos, cont), pending_mouseup.get()));
      _ = Dom.bind(canvas_sel, { mouseup }, handler_mouseup);
      void;
    gl = context;
    eng : engine =
      start = @openrecord({ context=gl; canvas={ selector=canvas_sel; ~width; ~height }; scene=List.empty; selector=canvas_sel;
        last_coord_fixer=Option.none });
      start = { start with shaderProgram=initShaders(gl) };
      start = { start with framePickBuffer=initPickBuffer(start) } ;
      { start with static_buffers.repcoords=
        { x=initLineXBuffers(gl, {x}); y=initLineXBuffers(gl, {y}); z=initLineXBuffers(gl, {z}) } };
    //Clear screen and make everything light gray // disabled to show png grid
    //do Webgl.clearColor(gl, 0.875, 0.875, 0.875, 1.0);
    //we should do depth testing so that things drawn behind other
    //things should be hidden by the things in front of them).
    do Webgl.clearDepth(gl, 1.0);
    do Webgl.enable(gl, Webgl.DEPTH_TEST(gl));
    do Webgl.depthFunc(gl, Webgl.LEQUAL(gl));
    do
      get_pending_mouseup_and_clean() =
        tmp = List.rev(pending_mouseup.get());
        do pending_mouseup.set(List.empty);
        tmp;
      drawScene_and_register(eng, get_scene, get_camera_setting, mode.get, get_pending_mouseup_and_clean);
    { success }
  | { ~ko } -> { failure=ko }
  end ;


making the selection view a little more reactive

type Modeler.objects = { cube: (float, float, float); id: hidden_id } ;

type Modeler.scene = { selection: option(Modeler.objects); others: list(Modeler.objects) };

type Modeler.tool.mode = {selection} / {add_cube} ;

type Modeler.modeler = {
  address: string;
  scene: Modeler.scene;
  mode: Modeler.tool.mode
} ;

Scene = {{
  empty() = { selection=Option.some({cube=(0.0, 0.0, -3.0); id=CHF()}); others=[ {cube=(3.0, 0.0, 0.0); id=CHF()}, {cube=(6.0, 0.0, 0.0); id=CHF()} ] };

  add_cube(scene, where) = { scene with others=List.cons({cube=(where.x, where.y, where.z); id=CHF()}, scene.others) };

  selection(scene, possible_target) =
    match (possible_target, scene.selection) with
    | ({none}, {none}) -> scene
    | ({none}, {~some}) -> { selection=Option.none; others=List.cons(some, scene.others) }
    | ({~some}, osel) ->
      //we put back the sel with others
      others = Option.switch((sel -> List.cons(sel, scene.others)), scene.others, osel);
      //we retrieve the new sel
      (new_sel, others) = List.extract_p((elt -> elt.id == some), others);
      do if Option.is_none(new_sel) then Log.error("Scene", "a selection failed to find the corresponding object");
      { selection=new_sel; ~others }
    end ;

}} ;

Modeler = {{
  empty(scene_url) = { address=scene_url; scene=Scene.empty(); mode={selection} } ;

  use_tool(modeler, where, possible_target) =
    do Log.info("Modeler", "using tool at ({where}) perhaps on the target: '{possible_target}' in mode: '{modeler.mode}'");
    match modeler.mode with
    | {add_cube} -> { modeler with scene=Scene.add_cube(modeler.scene, where) }
    | {selection} -> { modeler with scene=Scene.selection(modeler.scene, possible_target) }
    end ;

  change_tool(modeler, new_mode) = { modeler with mode=new_mode };

}} ;

type GuiModeler.t = {
  modeler: Modeler.modeler;
  subjects: {
    mode: subject(Modeler.tool.mode);
    selection: subject(option(Modeler.objects))
    }
} ;

@client GuiModeler = {{

  empty(scene_url) : GuiModeler.t =
    modeler = Modeler.empty(scene_url);
    subjects = { mode=Observable.make(modeler.mode); selection=Observable.make(modeler.scene.selection) };
    { ~modeler; ~subjects };

  @private on_message(state : GuiModeler.t, message) =
    set_modeler(modeler) = { set={ state with ~modeler } } ;
    set_subjects(subjects) = { set={ state with ~subjects } } ;
    set(state) = { set=state };
    match message with
    | {click_on_scene; ~where; ~possible_target} ->
      modeler = Modeler.use_tool(state.modeler, where, possible_target);
      if Observable.get_state(state.subjects.selection) == modeler.scene.selection then
        set_modeler(modeler)
      else
        subjects = { state.subjects with selection=Observable.change_state(modeler.scene.selection, state.subjects.selection) };
        set({ ~subjects; ~modeler })
    | {change_tool=new_mode} ->
      modeler = Modeler.change_tool(state.modeler, new_mode);
      subjects = { state.subjects with mode=Observable.change_state(new_mode, state.subjects.mode) };
      set({ ~subjects; ~modeler })
    end ;

  setup_menu(parent_sel, channel, s_mode) : void =
    f(some_mode) = match some_mode with
      | {selection} -> (<>*Sel*</>, <>Cube</>)
      | {add_cube} -> (<>Sel</>, <>*Cube*</>)
      end ;
    (id_a, id_b) = (Random.string(7), Random.string(7));
    on_mode_change =
      then_do(new_mode) =
        (text_a, text_b) = f(new_mode);
        Dom.transform([#{id_a}<- text_a, #{id_b}<- text_b]);
      { si=(->true); ~then_do; else_autoclean };
    do Observable.register(on_mode_change, s_mode);
    menu =
      s(x) = (_ -> Session.send(channel, {change_tool=x}));

. | .
;
    ignore(Dom.put_at_start(parent_sel, Dom.of_xhtml(menu)));

  setup_selection_view(parent_sel, s_selection) : void =
    id = Random.string(7);
    do
      f(some_selection) = match some_selection with
        | {none} -> <></>
        | {~some} -> <>{ "{some}" }</>
        end ;
      on_selection_change =
        then_do(new_selection) = Dom.transform([#{id}<- f(new_selection)]);
        { si=(->not(Dom.is_empty(#{id}))); ~then_do; else_autoclean };
      Observable.register(on_selection_change, s_selection);
    sel =

;
    ignore(Dom.put_at_end(parent_sel, Dom.of_xhtml(sel)));

  init(scene_url, parent_sel:dom, width, height) : void =
    id_canvas_canvas = "canvas_canvas" ;
    fail_msg =
      <>It seems that your browser and/or graphics card are incompatible with Webgl.Learn a little more about webgl support</> ;
    and_do(_) =
      (channel, get_scene, get_subjects) =
        (channel, get_state) = SessionExt.make_with_getter(empty(scene_url), on_message);
        (channel, (-> get_state().modeler.scene), (->get_state().subjects)) ;
      mouse_listener(e) = match e with
        | { mousedown; ~pos; ~possible_target } -> Session.send(channel, {click_on_scene; where={x=pos.f1; y=pos.f2; z=pos.f3}; ~possible_target})
        end ;
      res = initGL(#{id_canvas_canvas}, width, height, get_scene, mouse_listener) ;
      if Outcome.is_failure(res) then ignore(Dom.put_replace(parent_sel, Dom.of_xhtml(fail_msg)))
      else
        the_subjects = get_subjects();
        do setup_menu(parent_sel, channel, the_subjects.mode);
        setup_selection_view(parent_sel, the_subjects.selection);
    base =
      <canvas width={width} height={height} id=#{id_canvas_canvas} onready={and_do} ></canvas>;
    ignore(Dom.put_inside(parent_sel, Dom.of_xhtml(base)));

}}

type Modeler.objects = { cube: (float, float, float); id: hidden_id } ;

type Modeler.scene = { selection: option(Modeler.objects); others: list(Modeler.objects) };

type Modeler.tool.mode = {selection} / {add_cube} ;

type Modeler.modeler = {
  address: string;
  scene: Modeler.scene;
  mode: Modeler.tool.mode
} ;

Scene = {{
  empty() = { selection=Option.some({cube=(0.0, 0.0, -3.0); id=CHF()}); others=[ {cube=(3.0, 0.0, 0.0); id=CHF()}, {cube=(6.0, 0.0, 0.0); id=CHF()} ] };

  add_cube(scene, where) = { scene with others=List.cons({cube=(where.x, where.y, where.z); id=CHF()}, scene.others) };

  selection(scene, possible_target) =
    match (possible_target, scene.selection) with
    | ({none}, {none}) -> scene
    | ({none}, {~some}) -> { selection=Option.none; others=List.cons(some, scene.others) }
    | ({~some}, osel) ->
      //we put back the sel with others
      others = Option.switch((sel -> List.cons(sel, scene.others)), scene.others, osel);
      //we retrieve the new sel
      (new_sel, others) = List.extract_p((elt -> elt.id == some), others);
      do if Option.is_none(new_sel) then Log.error("Scene", "a selection failed to find the corresponding object");
      { selection=new_sel; ~others }
    end ;

}} ;

Modeler = {{
  empty(scene_url) = { address=scene_url; scene=Scene.empty(); mode={selection} } ;

  use_tool(modeler, where, possible_target) =
    do Log.info("Modeler", "using tool at ({where}) perhaps on the target: '{possible_target}' in mode: '{modeler.mode}'");
    match modeler.mode with
    | {add_cube} -> { modeler with scene=Scene.add_cube(modeler.scene, where) }
    | {selection} -> { modeler with scene=Scene.selection(modeler.scene, possible_target) }
    end ;

  change_tool(modeler, new_mode) = { modeler with mode=new_mode };

}} ;

type GuiModeler.t = {
  modeler: Modeler.modeler;
  subjects: {
    mode: subject(Modeler.tool.mode);
    selection: subject(option(Modeler.objects))
    }
} ;

@client GuiModeler = {{

  empty(scene_url) : GuiModeler.t =
    modeler = Modeler.empty(scene_url);
    subjects = { mode=Observable.make(modeler.mode); selection=Observable.make(modeler.scene.selection) };
    { ~modeler; ~subjects };

  @private on_message(state : GuiModeler.t, message) =
    set_modeler(modeler) = { set={ state with ~modeler } } ;
    set_subjects(subjects) = { set={ state with ~subjects } } ;
    set(state) = { set=state };
    match message with
    | {click_on_scene; ~where; ~possible_target} ->
      modeler = Modeler.use_tool(state.modeler, where, possible_target);
      if Observable.get_state(state.subjects.selection) == modeler.scene.selection then
        set_modeler(modeler)
      else
        subjects = { state.subjects with selection=Observable.change_state(modeler.scene.selection, state.subjects.selection) };
        set({ ~subjects; ~modeler })
    | {change_tool=new_mode} ->
      modeler = Modeler.change_tool(state.modeler, new_mode);
      subjects = { state.subjects with mode=Observable.change_state(new_mode, state.subjects.mode) };
      set({ ~subjects; ~modeler })
    end ;

  setup_menu(parent_sel, channel, s_mode) : void =
    f(some_mode) = match some_mode with
      | {selection} -> (<>*Sel*</>, <>Cube</>)
      | {add_cube} -> (<>Sel</>, <>*Cube*</>)
      end ;
    (id_a, id_b) = (Random.string(7), Random.string(7));
    on_mode_change =
      then_do(new_mode) =
        (text_a, text_b) = f(new_mode);
        Dom.transform([#{id_a}<- text_a, #{id_b}<- text_b]);
      { si=(->true); ~then_do; else_autoclean };
    do Observable.register(on_mode_change, s_mode);
    menu =
      s(x) = (_ -> Session.send(channel, {change_tool=x}));

. | .
;
    ignore(Dom.put_at_start(parent_sel, Dom.of_xhtml(menu)));

  init(scene_url, parent_sel:dom, width, height) : void =
    id_canvas_canvas = "canvas_canvas" ;
    fail_msg =
      <>It seems that your browser and/or graphics card are incompatible with Webgl.Learn a little more about webgl support</> ;
    and_do(_) =
      (channel, get_scene, get_subjects) =
        (channel, get_state) = SessionExt.make_with_getter(empty(scene_url), on_message);
        (channel, (-> get_state().modeler.scene), (->get_state().subjects)) ;
      mouse_listener(e) = match e with
        | { mousedown; ~pos; ~possible_target } -> Session.send(channel, {click_on_scene; where={x=pos.f1; y=pos.f2; z=pos.f3}; ~possible_target})
        end ;
      res = initGL(#{id_canvas_canvas}, width, height, get_scene, mouse_listener) ;
      if Outcome.is_failure(res) then ignore(Dom.put_replace(parent_sel, Dom.of_xhtml(fail_msg))) else setup_menu(parent_sel, channel, get_subjects().mode);
    base =
      <canvas width={width} height={height} id=#{id_canvas_canvas} onready={and_do} ></canvas>;
    ignore(Dom.put_inside(parent_sel, Dom.of_xhtml(base)));

}}


[fix] updated github buttons (iframe issue)

/*  A simple, one-room, scalable real-time web chat, with file sharing

    Copyright © 2010-2012 MLstate

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU Affero General Public License as
    published by the Free Software Foundation, either version 3 of the
    License, or (at your option) any later version.

    This program 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 Affero General Public License for more details.

    You should have received a copy of the GNU Affero General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*/

/**
 * @author David Rajchenbach-Teller
 * @author Henri Binsztok
 * @author Frederic Ye
 */

import stdlib.system
import stdlib.themes.bootstrap

/** Constants **/

GITHUB_USER = "Aqua-Ye"
GITHUB_REPO = "OpaChat"
NB_LAST_MSGS = 10

/** Types **/

type user = { int id, string name }
type source = { system } or { string user }
type message = {
  source source,
  string text,
  Date.date date,
}
type media = {
  source source,
  string name,
  string src,
  string mimetype,
  Date.date date,
}
type client_channel = channel(void)
type network_msg =
   {message message}
or {media media}
or {(user, client_channel) connection}
or {user disconnection}
or {stats}

/** Database **/

database opa_chat {
  message /history[{date}]
}

/** Top level values **/

exposed Network.network(network_msg) room = Network.cloud("room")
private reference(intmap(user)) users = ServerReference.create(IntMap.empty)
private launch_date = Date.now_gmt()

/** Connection **/

function server_observe(message) {
  match (message) {
  case {connection:(user, client_channel)} :
    ServerReference.update(users, IntMap.add(user.id, user, _))
    Network.broadcast({stats}, room)
    Session.on_remove(client_channel, function() {
      server_observe({disconnection:user})
    })
  case {disconnection:user} :
    ServerReference.update(users, IntMap.remove(user.id, _))
    Network.broadcast({stats}, room)
  default: void
  }
}

_ = Network.observe(server_observe, room)

/** Stats **/

// Compute uptime and memory usage (MB)
function compute_stats() {
  uptime = Date.between(launch_date, Date.now_gmt())
  mem = System.get_memory_usage()/(1024*1024)
  (uptime, mem)
}

client @async function update_stats((uptime, mem)) {
  #uptime = <>Uptime: {Duration.to_formatted_string(Duration.long_time_printer, uptime)}</>
  #memory = <>Memory: {mem} MB</>
}

/** Users **/

client @async function update_users(users) {
  #users = <>Users: {List.length(users)}</>
  #user_list =
{users}

}

/** Conversation **/

// converts a source into HTML
function source_to_html(source) {
  match (source) {
  case {system} :
  case {~user} : {user}
  }
}

private client function generic_update(stats, elements, printer) {
  update_stats(stats)
  List.iter(function(element) {
    date = Date.to_formatted_string(Date.default_printer, element.date)
    time = Date.to_string_time_only(element.date)
    line =

              {time}
              {printer(element)}

    #conversation =+ line
  }, elements)
  Dom.scroll_to_bottom(#conversation)
}

client @async function message_update(stats, list(message) messages) {
  generic_update(stats, messages, function(message) {
    source_to_html(message.source) <+>
    {message.text}
  })
}

client @async function media_update(stats, list(media) medias) {
  media_parser = parser {
    case "image/" .*: {image}
    case "audio/" .*: {audio}
    case "video/" .*: {video}
  }
  generic_update(stats, medias, function(media) {
    source_to_html(media.source) <+>
    ( match (Parser.try_parse(media_parser, media.mimetype)) {
      case {some:{image}}:

      case {some:{audio}}:
        <audio src="{media.src}"
               controls="controls"
               type="{media.mimetype}"
               preload="auto">
          Your browser does not support the audio tag!
        </audio>
      case {some:{video}}:
        <video src="{media.src}"
               controls="controls"
               preload="auto"
               type="{media.name}">
          Your browser does not support the video tag!
        </video>
      default:
        is sharing a file :
          {media.name}

      } )
  })
}

function file_uploaded(user)(name, mimetype, key) {
  media = {
    source: {user:user.name},
    ~name,
    src: "/file/{key}",
    ~mimetype,
    date: Date.now(),
  }
  Network.broadcast({~media}, room)
}

function observe_client(msg) {
  match (msg) {
  case {~message} :
    message_update(compute_stats(), [message])
  case {~media} :
    media_update(compute_stats(), [media])
  case {connection:(user, _)} :
    message = {
      source: {system},
      text : "{user.name} joined the room",
      date : Date.now(),
    }
    message_update(compute_stats(), [message])
  case {disconnection:user} :
    message = {
      source: {system},
      text : "{user.name} left the room",
      date : Date.now(),
    }
    message_update(compute_stats(), [message])
  case {stats} :
    update_stats(compute_stats())
    users = ServerReference.get(users)
            |> IntMap.To.val_list(_)
            |> List.sort_by(function(u){u.name}, _)
    users_html_list =
      List.map(function(user) {

{user.name}

      }, users)
    update_users(users_html_list)
  default : void
  }
}

// Init the client from the server
function init_client(user, client_channel, _) {
  // Observe client
  obs = Network.observe(observe_client, room)
  Network.broadcast({connection:(user, client_channel)}, room)
  // Observe disconnection
  Dom.bind_beforeunload_confirmation(function(_) {
    Network.broadcast({disconnection:user}, room)
    Network.unobserve(obs)
    none
  })
  // Send NB_LAST_MSGS messages
  iterator = DbSet.iterator(/opa_chat/history[limit NB_LAST_MSGS; order -date])
  history = Iter.to_list(iterator) |> List.rev(_)
  message_update(compute_stats(), history)
  // Initialize OpaShare
  OpaShare.init(file_uploaded(user))
}

@async function send_message(broadcast, _) {
  void broadcast(Dom.get_value(#entry))
  Dom.clear_value(#entry)
}

exposed @async function enter_chat(user_name, client_channel) {
  user = {
    id: Random.int(Limits.max_int),
    name: user_name
  }
  function broadcast(text) {
    message = {source:{user:user_name}, ~text, date:Date.now()}
    /opa_chat/history[date==message.date] <- message
    Network.broadcast({~message}, room)
  }
  #main =

Users online

      {OpaShare.html()}

        <input id=#entry
               autofocus="autofocus"
               onready={function(_){Dom.give_focus(#entry)}}
               onnewline={send_message(broadcast, _)}
               x-webkit-speech="x-webkit-speech"/>

}

@async function join(_) {
  name = Dom.get_value(#name)
  client_channel = Session.make_callback(ignore)
  enter_chat(name, client_channel)
}

/** Server **/

watch_button =

fork_button =

function build_page(content) {

OpaChat

      {watch_button}
      {fork_button}

{content}

}

// Page headers
headers =
  Xhtml.of_string_unsafe("
") <+>
  <meta charset="utf-8"></meta>
  <meta http-equiv="X-UA-Compatible" content="IE=edge,chrome=1"></meta>
  <meta name="viewport" content="width=device-width,initial-scale=1"></meta>

// Start page
function start() {
  page = build_page(

A real-time web chat built in Opa.

      <input id=#name
             placeholder="Name"
             autofocus="autofocus"
             onready={function(_){Dom.give_focus(#name)}}
             onnewline={join}/>
       <button class="btn primary"
               onclick={join}>Join</button>

  )
  Resource.full_page_with_doctype(
    "OpaChat - a real-time web chat built in Opa",
    {html5},
    page, headers, {success},
    []
  )
}

// Parse URL
url_parser = parser {
  case "/file/" key=Rule.integer:
    match (OpaShare.get(key)) {
    case {some:file}:
      Resource.binary(file.content, file.mimetype)
      |> Resource.add_header(_, {content_disposition:{attachment:file.name}})
    default: start()
    }
  case (.*): start()
}

// Start the server
Server.start(Server.http, [
  { resources : @static_resource_directory("resources") }, // include resources directory
  { register : {css:["/resources/css/style.css"]} }, // include CSS in headers
  { custom : url_parser } // URL parser
])


coding the grid builder

coding the grid builder

type engine.color = ColorFloat.color;
type engine.position = vec3;

type object.pickable = {
  vertexPositions: Webgl.WebGLBuffer;
  itemSize: int;
  numItems: int;
  vertexNormals: Webgl.WebGLBuffer;
  vertexIndexs: Webgl.WebGLBuffer;
  picking_color: engine.color;
  id: hidden_id;
  color: engine.color;
  position: engine.position;
  is_selected: bool;
  beginMode: Webgl.GLenum;
  numIndexs: int
}

type object.simple = {
  positions: Webgl.WebGLBuffer;
  itemSize: int; numItems: int;
  beginMode: Webgl.GLenum;
  color: engine.color;
};

type object = object.pickable;

display_simple(eng, object : object.simple) =
  rec gl = eng.context and color = object.color and shaderProgram = eng.shaderProgram;
  do Webgl.uniform3f(gl, shaderProgram.ambientColorUniform, color.f1, color.f2, color.f3);
  do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), object.positions);
  do Webgl.vertexAttribPointer(gl, shaderProgram.vertexPositionAttribute, object.itemSize, Webgl.FLOAT(gl), false, 0, 0);
  do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), object.positions);
  do Webgl.vertexAttribPointer(gl, shaderProgram.vertexNormalAttribute, object.itemSize, Webgl.FLOAT(gl), false, 0, 0);
  do Webgl.drawArrays(gl, Webgl.LINES(gl), 0, object.numItems);
  void ;

Lines = {{
  create(gl, vertices, color) =
    vertexPositionBuffer = Webgl.createBuffer(gl);
    do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), vertexPositionBuffer);
    do Webgl.bufferData(gl, Webgl.ARRAY_BUFFER(gl),
      Webgl.Float32Array.to_ArrayBuffer(Webgl.Float32Array.from_float_list(vertices)),
      Webgl.STATIC_DRAW(gl));
    itemSize = 3;
    do Debug.assert(mod(List.length(vertices), itemSize) == 0, (-> "Lines.create : the list got an incorrec size"));
    { positions=vertexPositionBuffer; ~itemSize; numItems=List.length(vertices) / itemSize; beginMode=Webgl.LINES(gl); ~color }

  grid(gl, right : int, left : int, by : int, len : float, maper, color) =
    right = (right / by : int) * by;
    left = (left / by : int) * by;
    state =
      f(state : 'state) : 'state =
        tmp = (float_of_int(state.i), len, float_of_int(state.i), -len)
        { l=List.cons(tmp, state.l); i=state.i + by };
      g(state) : bool = state.i <= left;
      for({i=right; l=List.empty}, f, g);
    l_a = List.flatten(List.map(((a, b, c, d) -> List.append(maper(a, b), maper(c, d)) ), state.l));
    l_b = List.flatten(List.map(((a, b, c, d) -> List.append(maper(b, a), maper(d, c)) ), state.l));
    create(gl, List.append(l_a, l_b) : list(float), color);

}}

display_pickable(eng, pMatrix, mvMatrix, object : object.pickable, overide_color_for_picking) =
  gl = eng.context; shaderProgram = eng.shaderProgram;
  color =
    if overide_color_for_picking then object.picking_color
    else if object.is_selected then (0.7, 0., 0.) else object.color;
  do Webgl.uniform3f(gl, shaderProgram.ambientColorUniform, color.f1, color.f2, color.f3);
  do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), object.vertexPositions);
  do Webgl.vertexAttribPointer(gl, shaderProgram.vertexPositionAttribute, object.itemSize, Webgl.FLOAT(gl), false, 0, 0);
  do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), object.vertexNormals);
  do Webgl.vertexAttribPointer(gl, shaderProgram.vertexNormalAttribute, object.itemSize, Webgl.FLOAT(gl), false, 0, 0);
  do Webgl.bindBuffer(gl, Webgl.ELEMENT_ARRAY_BUFFER(gl), object.vertexIndexs);

  mvMatrix = Stack.update_and_push(mvMatrix, (o, n -> mat4.translate(o, vec3.from_public(object.position), n))) ;
  do setMatrixUniforms(gl, shaderProgram, pMatrix, Stack.peek(mvMatrix));
  do Webgl.drawElements(gl, object.beginMode, object.numIndexs, Webgl.UNSIGNED_SHORT(gl), 0);
  void
;

Cube = {{
  create(gl, m_object : Scene.objects, is_selected) : object =
    //define our vertex positions as a list
    vertices = [
        // Front face
        -1.0, -1.0,  1.0,
         1.0, -1.0,  1.0,
         1.0,  1.0,  1.0,
        -1.0,  1.0,  1.0,

        // Back face
        -1.0, -1.0, -1.0,
        -1.0,  1.0, -1.0,
         1.0,  1.0, -1.0,
         1.0, -1.0, -1.0,

        // Top face
        -1.0,  1.0, -1.0,
        -1.0,  1.0,  1.0,
         1.0,  1.0,  1.0,
         1.0,  1.0, -1.0,

        // Bottom face
        -1.0, -1.0, -1.0,
         1.0, -1.0, -1.0,
         1.0, -1.0,  1.0,
        -1.0, -1.0,  1.0,

        // Right face
         1.0, -1.0, -1.0,
         1.0,  1.0, -1.0,
         1.0,  1.0,  1.0,
         1.0, -1.0,  1.0,

        // Left face
        -1.0, -1.0, -1.0,
        -1.0, -1.0,  1.0,
        -1.0,  1.0,  1.0,
        -1.0,  1.0, -1.0,
      ];
    vertexNormals = [
      // Front
       0.0,  0.0,  1.0,
       0.0,  0.0,  1.0,
       0.0,  0.0,  1.0,
       0.0,  0.0,  1.0,

      // Back
       0.0,  0.0, -1.0,
       0.0,  0.0, -1.0,
       0.0,  0.0, -1.0,
       0.0,  0.0, -1.0,

      // Top
       0.0,  1.0,  0.0,
       0.0,  1.0,  0.0,
       0.0,  1.0,  0.0,
       0.0,  1.0,  0.0,

      // Bottom
       0.0, -1.0,  0.0,
       0.0, -1.0,  0.0,
       0.0, -1.0,  0.0,
       0.0, -1.0,  0.0,

      // Right
       1.0,  0.0,  0.0,
       1.0,  0.0,  0.0,
       1.0,  0.0,  0.0,
       1.0,  0.0,  0.0,

      // Left
      -1.0,  0.0,  0.0,
      -1.0,  0.0,  0.0,
      -1.0,  0.0,  0.0,
      -1.0,  0.0,  0.0
    ];
    cubeVertexIndices = [
              0, 1, 2,      0, 2, 3,    // Front face
              4, 5, 6,      4, 6, 7,    // Back face
              8, 9, 10,     8, 10, 11,  // Top face
              12, 13, 14,   12, 14, 15, // Bottom face
              16, 17, 18,   16, 18, 19, // Right face
              20, 21, 22,   20, 22, 23  // Left face
          ];
    //global variable to hold the cube buffer
    //We create a buffer for the cube's vertex positions.
    cubeVertexPositionBuffer = Webgl.createBuffer(gl);
    //tells WebGL that any following operations that act on buffers should use the one we specify
    do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), cubeVertexPositionBuffer);
    //Now, we create a Float32Array object based on our list,
    //and tell WebGL to use it to fill the current buffer
    do Webgl.bufferData(gl, Webgl.ARRAY_BUFFER(gl), Webgl.Float32Array.to_ArrayBuffer(Webgl.Float32Array.from_float_list(vertices)), Webgl.STATIC_DRAW(gl));
    cubeVertexNormalBuffer = Webgl.createBuffer(gl);
    do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), cubeVertexNormalBuffer);
    do Webgl.bufferData(gl, Webgl.ARRAY_BUFFER(gl), Webgl.Float32Array.to_ArrayBuffer(Webgl.Float32Array.from_float_list(vertexNormals)), Webgl.STATIC_DRAW(gl));
    cubeVertexIndexBuffer = Webgl.createBuffer(gl);
    do Webgl.bindBuffer(gl, Webgl.ELEMENT_ARRAY_BUFFER(gl), cubeVertexIndexBuffer);
    do Webgl.bufferData(gl, Webgl.ELEMENT_ARRAY_BUFFER(gl), Webgl.Uint16Array.to_ArrayBuffer(Webgl.Uint16Array.from_int_list(cubeVertexIndices)), Webgl.STATIC_DRAW(gl));
    { vertexPositions=cubeVertexPositionBuffer; itemSize=3; numItems=24; vertexNormals=cubeVertexNormalBuffer; vertexIndexs=cubeVertexIndexBuffer; picking_color=ColorFloat.random(); id=m_object.id; color=m_object.color
    ; ~is_selected; position=m_object.cube; beginMode=Webgl.TRIANGLES(gl); numIndexs=36 } : object
  ;

}}

type engine.color = ColorFloat.color;
type engine.position = vec3;

type object.pickable = {
  vertexPositions: Webgl.WebGLBuffer;
  itemSize: int;
  numItems: int;
  vertexNormals: Webgl.WebGLBuffer;
  vertexIndexs: Webgl.WebGLBuffer;
  picking_color: engine.color;
  id: hidden_id;
  color: engine.color;
  position: engine.position;
  is_selected: bool;
  beginMode: Webgl.GLenum;
  numIndexs: int
}

type object.simple = {
  positions: Webgl.WebGLBuffer;
  itemSize: int; numItems: int;
  beginMode: Webgl.GLenum;
  color: engine.color;
};

type object = object.pickable;

display_simple(eng, object : object.simple) =
  rec gl = eng.context and color = object.color and shaderProgram = eng.shaderProgram;
  do Webgl.uniform3f(gl, shaderProgram.ambientColorUniform, color.f1, color.f2, color.f3);
  do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), object.positions);
  do Webgl.vertexAttribPointer(gl, shaderProgram.vertexPositionAttribute, object.itemSize, Webgl.FLOAT(gl), false, 0, 0);
  do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), object.positions);
  do Webgl.vertexAttribPointer(gl, shaderProgram.vertexNormalAttribute, object.itemSize, Webgl.FLOAT(gl), false, 0, 0);
  do Webgl.drawArrays(gl, Webgl.LINES(gl), 0, object.numItems);
  void ;

Lines = {{
  create(gl, vertices, color) =
    vertexPositionBuffer = Webgl.createBuffer(gl);
    do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), vertexPositionBuffer);
    do Webgl.bufferData(gl, Webgl.ARRAY_BUFFER(gl),
      Webgl.Float32Array.to_ArrayBuffer(Webgl.Float32Array.from_float_list(vertices)),
      Webgl.STATIC_DRAW(gl));
    itemSize = 3;
    do Debug.assert(mod(List.length(vertices), itemSize) == 0, (-> "Lines.create : the list got an incorrec size"));
    { positions=vertexPositionBuffer; ~itemSize; numItems=List.length(vertices) / itemSize; beginMode=Webgl.LINES(gl); ~color }
}}

display_pickable(eng, pMatrix, mvMatrix, object : object.pickable, overide_color_for_picking) =
  gl = eng.context; shaderProgram = eng.shaderProgram;
  color =
    if overide_color_for_picking then object.picking_color
    else if object.is_selected then (0.7, 0., 0.) else object.color;
  do Webgl.uniform3f(gl, shaderProgram.ambientColorUniform, color.f1, color.f2, color.f3);
  do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), object.vertexPositions);
  do Webgl.vertexAttribPointer(gl, shaderProgram.vertexPositionAttribute, object.itemSize, Webgl.FLOAT(gl), false, 0, 0);
  do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), object.vertexNormals);
  do Webgl.vertexAttribPointer(gl, shaderProgram.vertexNormalAttribute, object.itemSize, Webgl.FLOAT(gl), false, 0, 0);
  do Webgl.bindBuffer(gl, Webgl.ELEMENT_ARRAY_BUFFER(gl), object.vertexIndexs);

  mvMatrix = Stack.update_and_push(mvMatrix, (o, n -> mat4.translate(o, vec3.from_public(object.position), n))) ;
  do setMatrixUniforms(gl, shaderProgram, pMatrix, Stack.peek(mvMatrix));
  do Webgl.drawElements(gl, object.beginMode, object.numIndexs, Webgl.UNSIGNED_SHORT(gl), 0);
  void
;

Cube = {{
  create(gl, m_object : Scene.objects, is_selected) : object =
    //define our vertex positions as a list
    vertices = [
        // Front face
        -1.0, -1.0,  1.0,
         1.0, -1.0,  1.0,
         1.0,  1.0,  1.0,
        -1.0,  1.0,  1.0,

        // Back face
        -1.0, -1.0, -1.0,
        -1.0,  1.0, -1.0,
         1.0,  1.0, -1.0,
         1.0, -1.0, -1.0,

        // Top face
        -1.0,  1.0, -1.0,
        -1.0,  1.0,  1.0,
         1.0,  1.0,  1.0,
         1.0,  1.0, -1.0,

        // Bottom face
        -1.0, -1.0, -1.0,
         1.0, -1.0, -1.0,
         1.0, -1.0,  1.0,
        -1.0, -1.0,  1.0,

        // Right face
         1.0, -1.0, -1.0,
         1.0,  1.0, -1.0,
         1.0,  1.0,  1.0,
         1.0, -1.0,  1.0,

        // Left face
        -1.0, -1.0, -1.0,
        -1.0, -1.0,  1.0,
        -1.0,  1.0,  1.0,
        -1.0,  1.0, -1.0,
      ];
    vertexNormals = [
      // Front
       0.0,  0.0,  1.0,
       0.0,  0.0,  1.0,
       0.0,  0.0,  1.0,
       0.0,  0.0,  1.0,

      // Back
       0.0,  0.0, -1.0,
       0.0,  0.0, -1.0,
       0.0,  0.0, -1.0,
       0.0,  0.0, -1.0,

      // Top
       0.0,  1.0,  0.0,
       0.0,  1.0,  0.0,
       0.0,  1.0,  0.0,
       0.0,  1.0,  0.0,

      // Bottom
       0.0, -1.0,  0.0,
       0.0, -1.0,  0.0,
       0.0, -1.0,  0.0,
       0.0, -1.0,  0.0,

      // Right
       1.0,  0.0,  0.0,
       1.0,  0.0,  0.0,
       1.0,  0.0,  0.0,
       1.0,  0.0,  0.0,

      // Left
      -1.0,  0.0,  0.0,
      -1.0,  0.0,  0.0,
      -1.0,  0.0,  0.0,
      -1.0,  0.0,  0.0
    ];
    cubeVertexIndices = [
              0, 1, 2,      0, 2, 3,    // Front face
              4, 5, 6,      4, 6, 7,    // Back face
              8, 9, 10,     8, 10, 11,  // Top face
              12, 13, 14,   12, 14, 15, // Bottom face
              16, 17, 18,   16, 18, 19, // Right face
              20, 21, 22,   20, 22, 23  // Left face
          ];
    //global variable to hold the cube buffer
    //We create a buffer for the cube's vertex positions.
    cubeVertexPositionBuffer = Webgl.createBuffer(gl);
    //tells WebGL that any following operations that act on buffers should use the one we specify
    do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), cubeVertexPositionBuffer);
    //Now, we create a Float32Array object based on our list,
    //and tell WebGL to use it to fill the current buffer
    do Webgl.bufferData(gl, Webgl.ARRAY_BUFFER(gl), Webgl.Float32Array.to_ArrayBuffer(Webgl.Float32Array.from_float_list(vertices)), Webgl.STATIC_DRAW(gl));
    cubeVertexNormalBuffer = Webgl.createBuffer(gl);
    do Webgl.bindBuffer(gl, Webgl.ARRAY_BUFFER(gl), cubeVertexNormalBuffer);
    do Webgl.bufferData(gl, Webgl.ARRAY_BUFFER(gl), Webgl.Float32Array.to_ArrayBuffer(Webgl.Float32Array.from_float_list(vertexNormals)), Webgl.STATIC_DRAW(gl));
    cubeVertexIndexBuffer = Webgl.createBuffer(gl);
    do Webgl.bindBuffer(gl, Webgl.ELEMENT_ARRAY_BUFFER(gl), cubeVertexIndexBuffer);
    do Webgl.bufferData(gl, Webgl.ELEMENT_ARRAY_BUFFER(gl), Webgl.Uint16Array.to_ArrayBuffer(Webgl.Uint16Array.from_int_list(cubeVertexIndices)), Webgl.STATIC_DRAW(gl));
    { vertexPositions=cubeVertexPositionBuffer; itemSize=3; numItems=24; vertexNormals=cubeVertexNormalBuffer; vertexIndexs=cubeVertexIndexBuffer; picking_color=ColorFloat.random(); id=m_object.id; color=m_object.color
    ; ~is_selected; position=m_object.cube; beginMode=Webgl.TRIANGLES(gl); numIndexs=36 } : object
  ;

}}


added sum type for system messages vs. user messages

/*  A simple, one-room, scalable real-time web chat

    Copyright (C) 2010-2011  MLstate

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU Affero General Public License as
    published by the Free Software Foundation, either version 3 of the
    License, or (at your option) any later version.

    This program 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 Affero General Public License for more details.

    You should have received a copy of the GNU Affero General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*/

import stdlib.{date}
type author = { system } / { author : string }
type message = { author : author
               ; text : string
               ; date : Date.date
               }

db /history : list(message)

room = Network.cloud("room") : Network.network(message)

user_update(x: message) =
  line =

            {Date.to_string_time_only(x.date)}
            { match x.author with
              | {system} ->
              | {~author} -> {author} }
            {x.text}

  do Dom.transform([#conversation +<- line ])
  Dom.scroll_to_bottom(#conversation)

broadcast(author, text) =
   message = {~author ~text date=Date.now()}
   do Network.broadcast(message, room)
   do /history <- [message | /history]
   Dom.clear_value(#entry)

launch(author) =
   init_client() =
     history = List.rev(List.take(20, /history))
     do List.iter(user_update, history)
     Network.add_callback(user_update, room)
   send_message() =
     broadcast({~author}, Dom.get_value(#entry))
   logout() =
     do broadcast({system}, "{author} has left the room")
     Dom.transform([#main <- Reconnect])

 logout()}>Logout

 init_client()}>

   <input id=#entry  onnewline={_ -> send_message()}/>

 send_message()}>Send

start() =
   go(_) =
     author = Dom.get_value(#author)
     do Dom.transform([#main <- launch(author)])
     broadcast({system}, "{author} is connected to the room")

Choose your name:

     <input id=#author onnewline={go}/>

Launch

server = Server.one_page_bundle("Chat",
       [@static_resource_directory("resources")],
       ["resources/css.css"], start)

/*  A simple, one-room, scalable real-time web chat

    Copyright (C) 2010-2011  MLstate

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU Affero General Public License as
    published by the Free Software Foundation, either version 3 of the
    License, or (at your option) any later version.

    This program 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 Affero General Public License for more details.

    You should have received a copy of the GNU Affero General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*/

import stdlib.{date}

type message = { author : string
               ; text : string
               ; date : Date.date
               }

db /history : list(message)

room = Network.cloud("room") : Network.network(message)

user_update(x: message) =
  line =

            {Date.to_string_time_only(x.date)}
            {x.author}
            {x.text}

  do Dom.transform([#conversation +<- line ])
  Dom.scroll_to_bottom(#conversation)

broadcast(author, text) =
   message = {~author ~text date=Date.now()}
   do Network.broadcast(message, room)
   do /history <- [message | /history]
   Dom.clear_value(#entry)

launch(author) =
   init_client() =
     history = List.rev(List.take(20, /history))
     do List.iter(user_update, history)
     Network.add_callback(user_update, room)
   send_message() =
     broadcast(author, Dom.get_value(#entry))
   logout() =
     do broadcast("System", "{author} has left the room")
     Dom.transform([#main <- Reconnect])

 logout()}>Logout

 init_client()}>

   <input id=#entry  onnewline={_ -> send_message()}/>

 send_message()}>Send

start() =
   go(_) =
     author = Dom.get_value(#author)
     do Dom.transform([#main <- launch(author)])
     broadcast("System", "{author} is connected to the room")

Choose your name:

     <input id=#author onnewline={go}/>

Launch

server = Server.one_page_bundle("Chat",
       [@static_resource_directory("resources")],
       ["resources/css.css"], start)


renaming field and type

renaming field and type

type Modeler.objects = { cube: (float, float, float); id: hidden_id; color: ColorFloat.color } ;

type Modeler.scene = { selection: option(Modeler.objects); others: list(Modeler.objects) };

type Modeler.tool = {selection} / {add_cube} ;

type Modeler.modeler = {
  address: string;
  scene: Modeler.scene;
  tool: Modeler.tool
} ;

Scene = {{
  find_object(objects, target_id) : option(Modeler.objects) = List.find((z -> z.id == target_id), objects);
  extract_object(objects, target_id) : (option(Modeler.objects), list(Modeler.objects)) = List.extract_p((z -> z.id == target_id), objects);
  add_object(objects, object) : list(Modeler.objects) = List.cons(object, objects);

  change_selection_color(scene, new_color) : Modeler.scene =
    match scene.selection with
    | {none} -> scene
    | {some=an_object} -> { scene with selection=Option.some({ an_object with color=new_color }) }
    end ;

  empty() : Modeler.scene =
    c(pos) = {cube=pos; id=CHF(); color=ColorFloat.random()};
    { selection=Option.some(c((0.0, 0.0, -3.0))); others=[ c((3.0, 0.0, 0.0)), c((6.0, 0.0, 0.0)) ] };

  add_cube(scene, where) = { scene with others=List.cons({cube=(where.x, where.y, where.z); id=CHF(); color=ColorFloat.random()}, scene.others) };

  selection(scene, possible_target) =
    match (possible_target, scene.selection) with
    | ({none}, {none}) -> scene
    | ({none}, {~some}) -> { selection=Option.none; others=List.cons(some, scene.others) }
    | ({~some}, osel) ->
      //we put back the sel with others
      others = Option.switch((sel -> List.cons(sel, scene.others)), scene.others, osel);
      //we retrieve the new sel
      (new_sel, others) = List.extract_p((elt -> elt.id == some), others);
      do if Option.is_none(new_sel) then Log.error("Scene", "a selection failed to find the corresponding object");
      { selection=new_sel; ~others }
    end ;

}} ;

Modeler = {{
  empty(scene_url) : Modeler.modeler = { address=scene_url; scene=Scene.empty(); tool={selection} } ;

  use_tool(modeler, where, possible_target)  : Modeler.modeler =
    do Log.info("Modeler", "using tool at ({where}) perhaps on the target: '{possible_target}' with tool: '{modeler.tool}'");
    match modeler.tool with
    | {add_cube} -> { modeler with scene=Scene.add_cube(modeler.scene, where) }
    | {selection} -> { modeler with scene=Scene.selection(modeler.scene, possible_target) }
    end ;

  change_tool(modeler, new_tool) : Modeler.modeler = { modeler with tool=new_tool };

}} ;

type GuiModeler.t = {
  modeler: Modeler.modeler;
  subjects: {
    tool: subject(Modeler.tool);
    selection: subject(option(Modeler.objects))
    }
} ;

@client GuiModeler = {{

  empty(scene_url) : GuiModeler.t =
    modeler = Modeler.empty(scene_url);
    subjects = { tool=Observable.make(modeler.tool); selection=Observable.make(modeler.scene.selection) };
    { ~modeler; ~subjects };

  @private on_message(state : GuiModeler.t, message) =
    set_modeler(modeler) = { set={ state with ~modeler } } ;
    set_subjects(subjects) = { set={ state with ~subjects } } ;
    set(state) = { set=state };
    match message with
    | {click_on_scene; ~where; ~possible_target} ->
      modeler = Modeler.use_tool(state.modeler, where, possible_target);
      if Observable.get_state(state.subjects.selection) == modeler.scene.selection then
        set_modeler(modeler)
      else
        subjects = { state.subjects with selection=Observable.change_state(modeler.scene.selection, state.subjects.selection) };
        set({ ~subjects; ~modeler })
    | {change_tool=new_tool} ->
      modeler = Modeler.change_tool(state.modeler, new_tool);
      subjects = { state.subjects with tool=Observable.change_state(new_tool, state.subjects.tool) };
      set({ ~subjects; ~modeler })
    end ;

  setup_menu(parent_sel, channel, s_tool) : void =
    f(some_tool) = match some_tool with
      | {selection} -> (<>*Sel*</>, <>Cube</>)
      | {add_cube} -> (<>Sel</>, <>*Cube*</>)
      end ;
    (id_a, id_b) = (Random.string(7), Random.string(7));
    on_tool_change =
      then_do(new_tool) =
        (text_a, text_b) = f(new_tool);
        Dom.transform([#{id_a}<- text_a, #{id_b}<- text_b]);
      { si=(-> not(Dom.is_empty(#{id_a})) && not(Dom.is_empty(#{id_b}))); ~then_do; else_autoclean };
    do Observable.register(on_tool_change, s_tool);
    menu =
      s(x) = (_ -> Session.send(channel, {change_tool=x}));

. | .
;
    ignore(Dom.put_at_start(parent_sel, Dom.of_xhtml(menu)));

  setup_selection_view(parent_sel, s_selection) : void =
    id = Random.string(7);
    do
      f(some_selection) = match some_selection with
        | {none} -> <></>
        | {~some} -> <>{ "{some}" }</>
        end ;
      on_selection_change =
        then_do(new_selection) = Dom.transform([#{id}<- f(new_selection)]);
        { si=(->not(Dom.is_empty(#{id}))); ~then_do; else_autoclean };
      Observable.register(on_selection_change, s_selection);
    sel =

;
    ignore(Dom.put_at_end(parent_sel, Dom.of_xhtml(sel)));

  init(scene_url, parent_sel:dom, width, height) : void =
    id_canvas_canvas = "canvas_canvas" ;
    fail_msg =
      <>It seems that your browser and/or graphics card are incompatible with Webgl.Learn a little more about webgl support</> ;
    and_do(_) =
      (channel, get_scene, get_subjects) =
        (channel, get_state) = SessionExt.make_with_getter(empty(scene_url), on_message);
        (channel, (-> get_state().modeler.scene), (->get_state().subjects)) ;
      mouse_listener(e) = match e with
        | { mousedown; ~pos; ~possible_target } -> Session.send(channel, {click_on_scene; where={x=pos.f1; y=pos.f2; z=pos.f3}; ~possible_target})
        end ;
      res = initGL(#{id_canvas_canvas}, width, height, get_scene, mouse_listener) ;
      if Outcome.is_failure(res) then ignore(Dom.put_replace(parent_sel, Dom.of_xhtml(fail_msg)))
      else
        the_subjects = get_subjects();
        do setup_menu(parent_sel, channel, the_subjects.tool);
        setup_selection_view(parent_sel, the_subjects.selection);
    base =
      <canvas width={width} height={height} id=#{id_canvas_canvas} onready={and_do} ></canvas>;
    ignore(Dom.put_inside(parent_sel, Dom.of_xhtml(base)));

}}

type Modeler.objects = { cube: (float, float, float); id: hidden_id; color: ColorFloat.color } ;

type Modeler.scene = { selection: option(Modeler.objects); others: list(Modeler.objects) };

type Modeler.tool.mode = {selection} / {add_cube} ;

type Modeler.modeler = {
  address: string;
  scene: Modeler.scene;
  mode: Modeler.tool.mode
} ;

Scene = {{
  find_object(objects, target_id) : option(Modeler.objects) = List.find((z -> z.id == target_id), objects);
  extract_object(objects, target_id) : (option(Modeler.objects), list(Modeler.objects)) = List.extract_p((z -> z.id == target_id), objects);
  add_object(objects, object) : list(Modeler.objects) = List.cons(object, objects);

  change_selection_color(scene, new_color) : Modeler.scene =
    match scene.selection with
    | {none} -> scene
    | {some=an_object} -> { scene with selection=Option.some({ an_object with color=new_color }) }
    end ;

  empty() : Modeler.scene =
    c(pos) = {cube=pos; id=CHF(); color=ColorFloat.random()};
    { selection=Option.some(c((0.0, 0.0, -3.0))); others=[ c((3.0, 0.0, 0.0)), c((6.0, 0.0, 0.0)) ] };

  add_cube(scene, where) = { scene with others=List.cons({cube=(where.x, where.y, where.z); id=CHF(); color=ColorFloat.random()}, scene.others) };

  selection(scene, possible_target) =
    match (possible_target, scene.selection) with
    | ({none}, {none}) -> scene
    | ({none}, {~some}) -> { selection=Option.none; others=List.cons(some, scene.others) }
    | ({~some}, osel) ->
      //we put back the sel with others
      others = Option.switch((sel -> List.cons(sel, scene.others)), scene.others, osel);
      //we retrieve the new sel
      (new_sel, others) = List.extract_p((elt -> elt.id == some), others);
      do if Option.is_none(new_sel) then Log.error("Scene", "a selection failed to find the corresponding object");
      { selection=new_sel; ~others }
    end ;

}} ;

Modeler = {{
  empty(scene_url) = { address=scene_url; scene=Scene.empty(); mode={selection} } ;

  use_tool(modeler, where, possible_target) =
    do Log.info("Modeler", "using tool at ({where}) perhaps on the target: '{possible_target}' in mode: '{modeler.mode}'");
    match modeler.mode with
    | {add_cube} -> { modeler with scene=Scene.add_cube(modeler.scene, where) }
    | {selection} -> { modeler with scene=Scene.selection(modeler.scene, possible_target) }
    end ;

  change_tool(modeler, new_mode) = { modeler with mode=new_mode };

}} ;

type GuiModeler.t = {
  modeler: Modeler.modeler;
  subjects: {
    mode: subject(Modeler.tool.mode);
    selection: subject(option(Modeler.objects))
    }
} ;

@client GuiModeler = {{

  empty(scene_url) : GuiModeler.t =
    modeler = Modeler.empty(scene_url);
    subjects = { mode=Observable.make(modeler.mode); selection=Observable.make(modeler.scene.selection) };
    { ~modeler; ~subjects };

  @private on_message(state : GuiModeler.t, message) =
    set_modeler(modeler) = { set={ state with ~modeler } } ;
    set_subjects(subjects) = { set={ state with ~subjects } } ;
    set(state) = { set=state };
    match message with
    | {click_on_scene; ~where; ~possible_target} ->
      modeler = Modeler.use_tool(state.modeler, where, possible_target);
      if Observable.get_state(state.subjects.selection) == modeler.scene.selection then
        set_modeler(modeler)
      else
        subjects = { state.subjects with selection=Observable.change_state(modeler.scene.selection, state.subjects.selection) };
        set({ ~subjects; ~modeler })
    | {change_tool=new_mode} ->
      modeler = Modeler.change_tool(state.modeler, new_mode);
      subjects = { state.subjects with mode=Observable.change_state(new_mode, state.subjects.mode) };
      set({ ~subjects; ~modeler })
    end ;

  setup_menu(parent_sel, channel, s_mode) : void =
    f(some_mode) = match some_mode with
      | {selection} -> (<>*Sel*</>, <>Cube</>)
      | {add_cube} -> (<>Sel</>, <>*Cube*</>)
      end ;
    (id_a, id_b) = (Random.string(7), Random.string(7));
    on_mode_change =
      then_do(new_mode) =
        (text_a, text_b) = f(new_mode);
        Dom.transform([#{id_a}<- text_a, #{id_b}<- text_b]);
      { si=(-> not(Dom.is_empty(#{id_a})) && not(Dom.is_empty(#{id_b}))); ~then_do; else_autoclean };
    do Observable.register(on_mode_change, s_mode);
    menu =
      s(x) = (_ -> Session.send(channel, {change_tool=x}));

. | .
;
    ignore(Dom.put_at_start(parent_sel, Dom.of_xhtml(menu)));

  setup_selection_view(parent_sel, s_selection) : void =
    id = Random.string(7);
    do
      f(some_selection) = match some_selection with
        | {none} -> <></>
        | {~some} -> <>{ "{some}" }</>
        end ;
      on_selection_change =
        then_do(new_selection) = Dom.transform([#{id}<- f(new_selection)]);
        { si=(->not(Dom.is_empty(#{id}))); ~then_do; else_autoclean };
      Observable.register(on_selection_change, s_selection);
    sel =

;
    ignore(Dom.put_at_end(parent_sel, Dom.of_xhtml(sel)));

  init(scene_url, parent_sel:dom, width, height) : void =
    id_canvas_canvas = "canvas_canvas" ;
    fail_msg =
      <>It seems that your browser and/or graphics card are incompatible with Webgl.Learn a little more about webgl support</> ;
    and_do(_) =
      (channel, get_scene, get_subjects) =
        (channel, get_state) = SessionExt.make_with_getter(empty(scene_url), on_message);
        (channel, (-> get_state().modeler.scene), (->get_state().subjects)) ;
      mouse_listener(e) = match e with
        | { mousedown; ~pos; ~possible_target } -> Session.send(channel, {click_on_scene; where={x=pos.f1; y=pos.f2; z=pos.f3}; ~possible_target})
        end ;
      res = initGL(#{id_canvas_canvas}, width, height, get_scene, mouse_listener) ;
      if Outcome.is_failure(res) then ignore(Dom.put_replace(parent_sel, Dom.of_xhtml(fail_msg)))
      else
        the_subjects = get_subjects();
        do setup_menu(parent_sel, channel, the_subjects.mode);
        setup_selection_view(parent_sel, the_subjects.selection);
    base =
      <canvas width={width} height={height} id=#{id_canvas_canvas} onready={and_do} ></canvas>;
    ignore(Dom.put_inside(parent_sel, Dom.of_xhtml(base)));

}}


* opa/pfff_logger.opa: #unique users

* opa/pfff_logger.opa: #unique users

//****************************************************************************
// Prelude
//****************************************************************************
/*
 * My poor's man version of scribe and ODS ... to log the use of the different
 * pfff tools: codemap, codequery, sgrep, spatch, cmf (--fix, --strict/--bugs,
 * --deadcode, -mv_module), etc
 *
 * It's a good OPA exercice: need a state (db), some simple
 * visualization (web ui), and it needs to be accessible from anywhere
 * (web service). No need to install any special things on the machine
 * of the user (does it handle scribe, how to aggregate scribe of
 * all machines, etc).
 *
 * history:
 *  - opti: need to use /db[cmd][date] cos reinsert full list is too slow
 *
 *
 * alternatives:
 *  - log in a file on a shared NFS dir and then elsewhere do the aggregation
 *  - use RPC (thrift), which would be more typed than abusing urls and json
 *  - use couchdb or mongodb, via OPA api, or just curl them?
 *  - use couchdb or mongodb directly without OPA at all ...
 *  - use ocamlnet
 *
 * todo: too slow,
 *  - how to efficiently get the keys at the first level (all tools)?
 *  - how to allow concurrent access to the db? need run multiple opa?
 *    use opa-cloud with its load balancer? but is db itself concurrent?
 */

//****************************************************************************
// The db
//****************************************************************************

type command_name = string
type command_run = {
   string unixname,
   string extra_args,
   Date.date date
}

// command_name -> list(command_run)
database stringmap(intmap(command_run)) /db1

database int /counter = 0

//****************************************************************************
// Stringof
//****************************************************************************

function string_of_command_run(command_run x) {
  "{Date.to_debug_string(x.date)}| " ^
  "{x.unixname}|" ^
  "args = {x.extra_args}"
}

//****************************************************************************
// Query
//****************************************************************************

function users_of_cmd(string cmd) {
  intmap = /db1[cmd];
  vals = Map.To.val_list(intmap);
  users = List.map(function (x) { x.unixname }, vals);
  set = Set.From.list(users);
  set
}

function view_all_cmds() {
  strmap = /db1;
  keys = Map.To.key_list(strmap);
  keys_with_stats = List.map(function (cmd) {
    users = users_of_cmd(cmd);
    (cmd, Set.size(users))
    }, keys);
  String.concat("\n",
    List.map(function ((cmd, n)) {"{cmd}({n})"}, keys_with_stats))
}

function view_cmd(string cmd) {
  intmap = /db1[cmd];
  vals = Map.To.val_list(intmap);
  ys = List.map(string_of_command_run, vals);
  String.concat("\n", ys)
}

//****************************************************************************
// Save
//****************************************************************************
function save_command_run(command_name cmd, option(RPC.Json.json) json) {
  match (json) {
  //henry: why can't write deep pattern? get some "cyclic type error" :(
  case {some: json}:
    match (json) {
    case {Record: [("unixname", x), ("extra_args", y)]}:
      match ((x, y)) {
      case ({String: s1}, {String:s2}):
        now = Date.now();
        entry = { unixname: s1, extra_args: s2, date: now }
        /counter <- /counter + 1;
        //old: slow  /db1[cmd] <- [ entry | /db1[cmd] ];
        /db1[cmd][Date.in_milliseconds(now)] <- entry;
        {success}
      default:
        {bad_request}
      }
    default:
      {bad_request}
    }
  default:
    {bad_request}
  }
}

//****************************************************************************
// Web visualization
//****************************************************************************

//****************************************************************************
// The router
//****************************************************************************

function start(Uri.relative url) {
  match (url) {
  case {path: [] ... }:
    Resource.page("Pfff",
Pfff
)

  case {path: ["_rest_", command] ...}:
    match (HttpRequest.get_method()) {
    case {some: { post } } :
     Resource.raw_status(
       save_command_run(command, HttpRequest.get_json_body())
     )
    default:
      Resource.raw_status({bad_request})
    }

  case {path: ["view", "counter"] ...}:
    Resource.raw_text("counter = {/counter}\n")
  case {path: ["view", "list"] ...}:
    Resource.raw_text(view_all_cmds())
  case {path: ["view", cmd] ...}:
    Resource.raw_text(view_cmd(cmd))

  default:
    Resource.raw_status({bad_request})
   }
}

Server.start(Server.http, [
   { dispatch: start }
 ]
)

//****************************************************************************
// Prelude
//****************************************************************************
/*
 * My poor's man version of scribe and ODS ... to log the use of the different
 * pfff tools: codemap, codequery, sgrep, spatch, cmf (--fix, --strict/--bugs,
 * --deadcode, -mv_module), etc
 *
 * It's a good OPA exercice: need a state (db), some simple
 * visualization (web ui), and it needs to be accessible from anywhere
 * (web service). No need to install any special things on the machine
 * of the user (does it handle scribe, how to aggregate scribe of
 * all machines, etc).
 *
 * history:
 *  - opti: need to use /db[cmd][date] cos reinsert full list is too slow
 *
 *
 * alternatives:
 *  - log in a file on a shared NFS dir and then elsewhere do the aggregation
 *  - use RPC (thrift), which would be more typed than abusing urls and json
 *  - use couchdb or mongodb, via OPA api, or just curl them?
 *  - use couchdb or mongodb directly without OPA at all ...
 *  - use ocamlnet
 *
 * todo: too slow,
 *  - how to efficiently get the keys at the first level (all tools)?
 *  - how to allow concurrent access to the db? need run multiple opa?
 *    use opa-cloud with its load balancer? but is db itself concurrent?
 */

//****************************************************************************
// The db
//****************************************************************************

type command_name = string
type command_run = {
   string unixname,
   string extra_args,
   Date.date date
}

// command_name -> list(command_run)
database stringmap(intmap(command_run)) /db1

database int /counter = 0

//****************************************************************************
// Stringof
//****************************************************************************

function string_of_command_run(command_run x) {
  "{Date.to_debug_string(x.date)}| " ^
  "{x.unixname}|" ^
  "args = {x.extra_args}"
}

//****************************************************************************
// Query
//****************************************************************************

function view_list() {
  strmap = /db1;
  //todo: this is really slow
  keys = Map.To.key_list(strmap);
  String.concat("\n", keys)
}

function view(string cmd) {
  intmap = /db1[cmd];
  vals = Map.To.val_list(intmap);
  ys = List.map(string_of_command_run, vals);
  String.concat("\n", ys)
}

//****************************************************************************
// Save
//****************************************************************************
function save_command_run(command_name cmd, option(RPC.Json.json) json) {
  match (json) {
  //henry: why can't write deep pattern? get some "cyclic type error" :(
  case {some: json}:
    match (json) {
    case {Record: [("unixname", x), ("extra_args", y)]}:
      match ((x, y)) {
      case ({String: s1}, {String:s2}):
        now = Date.now();
        entry = { unixname: s1, extra_args: s2, date: now }
        /counter <- /counter + 1;
        //old: slow  /db1[cmd] <- [ entry | /db1[cmd] ];
        /db1[cmd][Date.in_milliseconds(now)] <- entry;
        {success}
      default:
        {bad_request}
      }
    default:
      {bad_request}
    }
  default:
    {bad_request}
  }
}

//****************************************************************************
// Web visualization
//****************************************************************************

//****************************************************************************
// The router
//****************************************************************************

function start(Uri.relative url) {
  match (url) {
  case {path: [] ... }:
    Resource.page("Pfff",
Pfff
)

  case {path: ["_rest_", command] ...}:
    match (HttpRequest.get_method()) {
    case {some: { post } } :
     Resource.raw_status(
       save_command_run(command, HttpRequest.get_json_body())
     )
    default:
      Resource.raw_status({bad_request})
    }

  case {path: ["view", "counter"] ...}:
    Resource.raw_text("counter = {/counter}\n")
  case {path: ["view", "list"] ...}:
    Resource.raw_text(view_list())
  case {path: ["view", cmd] ...}:
    Resource.raw_text(view(cmd))

  default:
    Resource.raw_status({bad_request})
   }
}

Server.start(Server.http, [
   { dispatch: start }
 ]
)