Building a training set of tags for ocaml

[iHiD]

Hello lovely maintainers :wave:

We've recently added "tags" to student's solutions. These express the constructs, paradigms and techniques that a solution uses. We are going to be using these tags for lots of things including filtering, pointing a student to alternative approaches, and much more.

In order to do this, we've built out a full AST-based tagger in C#, which has allowed us to do things like detect recursion or bit shifting. We've set things up so other tracks can do the same for their languages, but its a lot of work, and we've determined that actually it may be unnecessary. Instead we think that we can use machine learning to achieve tagging with good enough results. We've fine-tuned a model that can determine the correct tags for C# from the examples with a high success rate. It's also doing reasonably well in an untrained state for other languages. We think that with only a few examples per language, we can potentially get some quite good results, and that we can then refine things further as we go.

I released a new video on the Insiders page that talks through this in more detail.

We're going to be adding a fully-fledged UI in the coming weeks that allow maintainers and mentors to tag solutions and create training sets for the neural networks, but to start with, we're hoping you would be willing to manually tag 20 solutions for this track. In this post we'll add 20 comments, each with a student's solution, and the tags our model has generated. Your mission (should you choose to accept it) is to edit the tags on each issue, removing any incorrect ones, and add any that are missing. In order to build one model that performs well across languages, it's best if you stick as closely as possible to the C# tags as you can. Those are listed here. If you want to add extra tags, that's totally fine, but please don't arbitrarily reword existing tags, even if you don't like what Erik's chosen, as it'll just make it less likely that your language gets the correct tags assigned by the neural network.

---

To summarise - there are two paths forward for this issue:

1. You're up for helping: Add a comment saying you're up for helping. Update the tags some time in the next few days. Add a comment when you're done. We'll then add them to our training set and move forward.
2. You not up for helping: No problem! Just please add a comment letting us know :)

If you tell us you're not able/wanting to help or there's no comment added, we'll automatically crowd-source this in a week or so.

Finally, if you have questions or want to discuss things, it would be best done on the forum, so the knowledge can be shared across all maintainers in all tracks.

Thanks for your help! :blue_heart:

---

Note: Meta discussion on the forum

[iHiD]

Exercise: leap

Code

let leap_year year =
  year mod 4 = 0 && (year mod 10 != 0 || year mod 400 = 0)

Tags:

construct:boolean
construct:equals
construct:function
construct:implicit-boolean-conversion
construct:integer
construct:integral-number
construct:let-binding
construct:logical-and
construct:logical-or
construct:not-equal
construct:number
construct:parameter
construct:pattern-matching
construct:variable
construct:visibility-modifiers
paradigm:functional
paradigm:imperative
paradigm:logical
technique:boolean-logic
technique:boolean-arithmetic

[iHiD]

Exercise: hamming

Code

open Core.Std

type nucleotide = A | C | G | T

let compare (x : nucleotide) (y : nucleotide) : bool =
  match x, y with
  | A, A | C, C | G, G | T, T -> true
  | _, _ -> false

let rec zip (xs : 'a list) (ys : 'b list) : ('a * 'b) list =
  match xs, ys with
  | [], _ -> []
  | _, [] -> []
  | x :: xs', y :: ys' -> (x, y) :: zip xs' ys'

(** Compute the hammning distance between the two lists. *)
let hamming_distance (xs : nucleotide list) (ys : nucleotide list) : int =
  zip xs ys
  |> List.filter ~f:(fun (x, y) -> not (compare x y))
  |> List.length

Tags:

construct:applicative
construct:bool
construct:char
construct:constructor
construct:functor
construct:implicit-argument
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:let-binding
construct:list
construct:match
construct:optional-argument
construct:parameterized-type
construct:pattern-matching
construct:pipe-forward
construct:recursion
construct:type
construct:underscore
paradigm:functional
paradigm:object-oriented
technique:higher-order-functions
technique:inheritance
technique:looping
technique:recursion
uses:List.t

[iHiD]

Exercise: difference-of-squares

Code

open Core

let square x = x * x

let square_of_sum n =
  square @@ (n * succ n) / 2

let sum_of_squares n =
  n * succ n * succ (2 * n) / 6

let difference_of_squares n =
  (square_of_sum n) - (sum_of_squares n)

Tags:

construct:application
construct:divide
construct:floating-point-number
construct:function
construct:implicit-conversion
construct:int
construct:integral-number
construct:let-binding
construct:multiply
construct:number
construct:open
construct:parentheses
construct:subtract
construct:underscore
construct:variable
construct:visibility-modifiers
paradigm:functional
paradigm:object-oriented

[iHiD]

Exercise: triangle

Code

let equality  = function
  | [0; 0; 0] -> false
  | [a; b; c] -> a + b >= c && b + c >= a && a + c >= b 
  | _ -> false

let equilateral = function
  | [a; b; c] -> (a = b && b = c)
  | _ -> false

let isoceles = function
  | [a; b; c] -> (a = b || b = c || a = c)
  | _ -> false

let triangle f xs = equality xs && f xs

let is_isoceles = triangle isoceles

let is_equilateral = triangle equilateral

let is_scalene x = 
  equality x 
  && not (is_equilateral x)
  && not (is_isoceles x)

Tags:

construct:add
construct:boolean
construct:conjunct
construct:equals
construct:function
construct:ignore
construct:int
construct:integral-number
construct:let
construct:list
construct:logical-or
construct:match
construct:nested-function
construct:parameter
construct:pattern-matching
construct:variable
construct:visibility
paradigm:functional
paradigm:logical
technique:boolean-logic
technique:higher-order-functions

[iHiD]

Exercise: prime-factors

Code

open Core.Std
open Int64

let factors_of : int64 -> int64 list =
  let rec aux (p: int64) (acc: int64 list) : int64 -> int64 list = function
    | 1L -> acc
    | n when rem n p = 0L -> aux p (p :: acc) (n / p)
    | n -> aux (p + 1L) acc n
  in
  Fn.compose List.rev (aux 2L [])

Tags:

construct:add
construct:divide
construct:equals
construct:expression
construct:function
construct:invocation
construct:int64
construct:label
construct:list
construct:long
construct:open
construct:parameter
construct:pattern-matching
construct:recursion
construct:when-guard
paradigm:functional
paradigm:object-oriented
technique:higher-order-functions
technique:recursion

[iHiD]

Exercise: rectangles

Code

open Base

type coords = int * int
type diagram = string array

let iter_diagram (diagram: diagram) : (coords * char) list =
  diagram
  |> Array.to_list
  |> List.concat_mapi ~f: (fun y row ->
    String.to_list row
    |> List.mapi ~f: (fun x c ->
      ((x, y), c)
    )
  )

let positions_with_char (diagram: diagram) (c: char) : coords list =
  iter_diagram diagram
  |> List.filter_map ~f: (fun (coord, v) ->
    if Char.equal c v then
      Some coord
    else
      None
  )

let unique_ints (l: int list) : int list =
  List.dedup_and_sort l ~compare: Int.compare

let get_xs (positions: coords list) : int list =
  List.map positions ~f: (fun (x, _) -> x)
  |> unique_ints

let get_ys (positions: coords list) : int list =
  List.map positions ~f: (fun (_, y) -> y)
  |> unique_ints

let check_positions (positions: coords list) : bool =
  List.length positions = 4 &&
  List.length (get_xs positions) = 2 &&
  List.length (get_ys positions) = 2

let take_two (l: int list) : (int * int) option =
  match l with
  | n1 :: n2 :: _ -> Some (n1, n2)
  | _ -> None

let normalize_positions (positions: coords list) : (coords * coords) option =
  match (take_two (get_xs positions), take_two (get_ys positions)) with
  | (Some (x1, x2), Some (y1, y2)) -> Some ((x1, y1), (x2, y2))
  | _ -> None

let at (diagram: diagram) (x: int) (y: int) : char =
  let row = Array.get diagram y in
  String.get row x

let contains (l: char list) (c: char) : bool =
  List.exists l ~f: (fun v -> Char.equal c v)

let check_lines_for_coordinates (diagram: diagram) ((top_left): coords) (bottom_right: coords) : bool =
  let (x1, y1) = top_left in
  let (x2, y2) = bottom_right in
  let xs = List.range x1 x2 ~stop: `inclusive in
  let ys = List.range y1 y2 ~stop: `inclusive in
  List.for_all xs ~f: (fun x -> contains ['+';'-'] (at diagram x y1)) &&
    List.for_all xs ~f: (fun x -> contains ['+';'-'] (at diagram x y2)) &&
    List.for_all ys ~f: (fun y -> contains ['+';'|'] (at diagram x1 y)) &&
    List.for_all ys ~f: (fun y -> contains ['+';'|'] (at diagram x2 y))

let check_lines (diagram: diagram) (positions: coords list) : bool =
  match normalize_positions positions with
  | Some (top_left, bottom_right) -> check_lines_for_coordinates diagram top_left bottom_right
  | _ -> false

let is_rectangle (diagram: diagram) (positions: coords list) : bool =
  (check_positions positions) && (check_lines diagram positions)

let rec combinations (n: int) (l: coords list): (coords list) list =
  if n <= 0 then [ [] ]
  else match l with
   | [] -> []
   | h :: tl ->
    let with_h = List.map ~f: (fun l -> h :: l) (combinations (n - 1) tl) in
    let without_h = combinations n tl in
    with_h @ without_h

let count_rectangles (diagram: diagram) : int =
  combinations 4 (positions_with_char diagram '+')
  |> List.count ~f: (fun (positions: coords list) ->
    is_rectangle diagram positions
  )

Tags:

construct:add
construct:array
construct:assignment
construct:char
construct:constructor
construct:curried-function
construct:functor
construct:if-then-else
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:list
construct:logical-and
construct:match
construct:named-argument
construct:number
construct:optional-argument
construct:pattern-matching
construct:recursion
construct:string
construct:subtract
construct:tuple
construct:type
construct:underscore
construct:variant
construct:visibility-modifiers
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:boolean-logic
technique:higher-order-functions
technique:looping
uses:List

[iHiD]

Exercise: list-ops

Code

let length lst =
  let rec length_acc n = function
    | [] -> n
    | _ :: xs -> length_acc (n+1) xs 
  in length_acc 0 lst

let reverse lst =
  let rec reverse_acc reversed  = function
    | [] -> reversed
    | x :: xs -> reverse_acc (x::reversed) xs
  in reverse_acc [] lst

let map ~f lst  =
  let rec map_rev revres = function
    | [] -> revres
    | x :: xs -> map_rev ((f x)::revres) xs
  in  reverse (map_rev [] lst)

let filter ~f lst  =
  let rec filter_rev revres = function
    | [] -> revres
    | x :: xs -> if (f x) then filter_rev (x :: revres) xs
         else filter_rev revres xs
  in reverse (filter_rev [] lst)

let fold ~init ~f lst  =
  let rec loop accum = function
    | [] -> accum
    | x :: xs -> loop (f accum x) xs
  in loop init lst 

(* Straightforward and optimized for execution time. *)   
let append xxx yyy =
  let rec loop ys = function
    | [] -> ys
    | x :: xs -> x :: (loop ys xs)
  in loop yyy xxx

(* Tail-recursive, optimized for stack usage. *)      
let append xxx yyy =
  let rec loop ys = function
    | [] -> ys
    | x::xs -> loop (x::ys) xs
  in loop yyy (reverse xxx)

let concat lists  =
  let rec loop_lists result = function
    | [] -> result
    | xs :: xss ->
       let rec loop_elts result' = function
       [] -> result'
     | x' :: xs' ->  loop_elts (x' :: result') xs'
       in loop_lists (loop_elts result (reverse xs)) xss
  in loop_lists [] (reverse lists)

let concat lists =
  let rec prepend_elts tail = function
    | [] -> tail
    | x :: xs -> prepend_elts (x :: tail) xs in
  let rec prepend_lists tail = function
    | [] -> tail
    | xs :: xss -> prepend_lists (prepend_elts tail (reverse xs)) xss
  in prepend_lists [] (reverse lists)

let concat lists = 
  let prepend_elt tail elt = Core.Std.List.cons elt tail in 
  let rev_prepend_elts tail elts  =
    fold ~f:prepend_elt ~init:tail elts in
  let prepend_list tail lst = rev_prepend_elts tail (reverse lst) in 
  let rev_prepend_lists tail lsts =
    fold ~f:prepend_list ~init:tail lsts
  in rev_prepend_lists [] (reverse lists)

Tags:

construct:add
construct:annotation
construct:boolean
construct:comment
construct:curried-function
construct:function
construct:if-then-else
construct:invocation
construct:label
construct:let-binding
construct:list
construct:match
construct:named-argument
construct:number
construct:parameter
construct:pattern-matching
construct:recursion
construct:underscore
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:boolean
technique:higher-order-functions
technique:looping
technique:optimization
technique:recursion

[iHiD]

Exercise: dominoes

Code

open Base

type dominoe = (int * int) [@@deriving sexp]

(*
  The algorithm goes as follows:
    1. build_adj_mat:
      Build an undirected graph (adjacency matrix) where the dominoes are edges.
    2. In the main function chain:
      Check Euler's condition that all vertices have even degree.
      Not really needed as extract_cycle would return None at some point otherwise,
      which would propagate all the way.
    3. get_all_cycles:
      Repeatedly attempt to extract cycles from the graph (using extract_circle which
      just does a random walk until it gets stuck) until there's no edge left.
    4. build_path:
      Walk through the cycles, eagerly looking for opportunities to explore another cycle
      before going further along the existing one. If the graph is connected this will exhaust
      the cycles, otherwise return None.
*)

(* in the utility functions below, it is deliberate
   and crucial that we decrement / increment twice
   when i = j *)
let sym_incr mat i j =
  mat.(i).(j) <- mat.(i).(j) + 1;
  mat.(j).(i) <- mat.(j).(i) + 1

let sym_decr mat i j =
  if mat.(i).(j) > 0 then begin
    mat.(i).(j) <- mat.(i).(j) - 1;
    mat.(j).(i) <- mat.(j).(i) - 1
  end
  else
    invalid_arg "sym_decr"

let double_decr vec i j =
  if vec.(i) > 0 && vec.(j) > 0 then begin
    vec.(i) <- vec.(i) - 1;
    vec.(j) <- vec.(j) - 1;
  end else
    invalid_arg "double_decr"

let build_adj_mat edges length =
  let adj_mat = Array.make_matrix ~dimx:length ~dimy:length 0 in
  List.iter edges ~f:(fun (x, y) -> sym_incr adj_mat x y);
  adj_mat

(* not actually needed given the tests all use consecutive integers *)
let build_mapping doms =
  let map, size =
    let add_to_map map id x =
      match Map.add map ~key:x ~data:id with
      | `Ok map -> (map, id + 1)
      | `Duplicate -> (map, id) in
    List.fold doms ~init:((Map.empty (module Int)), 0) ~f:(fun (map, id) (x, y) ->
        let (map, id) = add_to_map map id x in
        add_to_map map id y) in
  let revmap = Array.create ~len:size 0 in
  Map.iteri map ~f:(fun ~key:name ~data:id -> revmap.(id) <- name);
  map, revmap

let extract_cycle adj_mat counts starting_point =
  let rec loop current_point path =
    match Array.findi adj_mat.(current_point) ~f:(fun _ x -> x > 0) with
    | Some (next_point, _) ->
      let () =
        sym_decr adj_mat current_point next_point;
        double_decr counts current_point next_point;
      in
      loop next_point ((next_point, current_point) :: path)
    | None ->
      Option.some_if (current_point = starting_point) path
  in
  loop starting_point []

let get_all_cycles adj_mat counts =
  let rec loop cycles =
    match Array.findi counts ~f:(fun _ x -> x > 0) with
    | Some (point, _) ->
      begin match extract_cycle adj_mat counts point with
        | Some cycle ->
          loop (Map.add_multi cycles ~key:point ~data:cycle)
        | None -> None
      end
    | None -> Some cycles
  in
  loop (Map.empty (module Int))

let build_path cycles =
  let rec walk_cycle cycle cur_point cycles path =
    match Map.find_multi cycles cur_point with
    | [] ->
      begin match cycle with
        | [] -> (path, cycles)
        | (x, y) :: rest ->
          walk_cycle rest y cycles ((y, x) :: path)
      end
    | other_cycle :: rest ->
      let new_cycles = Map.set cycles ~key:cur_point ~data:rest in  
      let new_path, new_cycles = walk_cycle other_cycle cur_point new_cycles path in
      walk_cycle cycle cur_point new_cycles new_path
  in
  let first_point, _ = Map.min_elt_exn cycles in
  let final_path, final_cycles = walk_cycle [] first_point cycles [] in
  Option.some_if (Map.for_all final_cycles ~f:List.is_empty) final_path

let chain doms =
  match doms with
  | [] -> Some []
  | _ ->
    let map, revmap = build_mapping doms in
    let edges = List.map doms ~f:(fun (x, y) -> (Map.find_exn map x, Map.find_exn map y)) in
    let n_verts = Map.length map in
    let adj_mat = build_adj_mat edges n_verts in
    let counts = Array.map adj_mat ~f:(Array.fold ~f:(+) ~init:0) in
    if not (Array.for_all counts ~f:(fun x -> x % 2 = 0)) then
      None (* Euler says no *)
    else
      get_all_cycles adj_mat counts
      |> Option.bind ~f:build_path
      |> Option.map ~f:(List.map ~f:(fun (x, y) -> (revmap.(x), revmap.(y))))

Tags:

construct:add
construct:array
construct:assignment
construct:boolean
construct:begin-end
construct:comment
construct:constructor
construct:fold-left
construct:functor
construct:if-then-else
construct:implicit-function-type
construct:indexing
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:list
construct:local-binding
construct:logical-and
construct:map
construct:match
construct:module
construct:multiply
construct:named-argument
construct:number
construct:open
construct:option
construct:parameter
construct:pattern-matching
construct:recursion
construct:set
construct:string
construct:subtract
construct:tuple
construct:type
construct:underscore
construct:variant
construct:visibility-modifiers
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:boolean-logic
technique:higher-order-functions
technique:looping
uses:List
uses:Map

[iHiD]

Exercise: connect

Code

type player = O | X

let normalize_char = function
  | 'X' -> Some (Some X)
  | 'O' -> Some (Some O)
  | '.' -> Some None
  | ' ' -> None (* the readme is a lie *)
  | c -> invalid_arg (Printf.sprintf "invalid character '%c'" c)

let normalize_str str =
  Iter.of_str str
  |> Iter.filter_map normalize_char
  |> Iter.to_array

let normalize_board rows =
  Iter.of_list rows
  |> Iter.map normalize_str
  |> Iter.to_array

let extend_board board =
  let h = Array.length board in
  let w = Array.length board.(0) in
  Array.init (h + 2) (fun x ->
      Array.init (w + 2) (fun y ->
          if x = 0 || x = h + 1 then
            Some O
          else if y = 0 || y = w + 1 then
            Some X
          else
            board.(x - 1).(y - 1)))

let is_valid ~h ~w ~x ~y =
  x >= 0 && x < h && y >= 0 && y < w

let neighbours_array x y = [|
  (x, y + 1);
  (x - 1, y + 1);
  (x - 1, y);
  (x, y - 1);
  (x + 1, y - 1);
  (x + 1, y);
|]

let valid_neighbours ~h ~w ~x ~y =
  neighbours_array x y
  |> Iter.of_array
  |> Iter.filter (fun (x, y) -> is_valid ~h ~w ~x ~y)

let component board x0 y0 =
  let h = Array.length board in
  let w = Array.length board.(0) in
  let target = board.(x0).(y0) in
  let result = Array.make_matrix h w false in
  let rec loop x y =
    if not result.(x).(y) then begin
      result.(x).(y) <- true;
      valid_neighbours ~h ~w ~x ~y
      |> Iter.filter (fun (x, y) -> board.(x).(y) = target)
      |> Iter.iter (fun (x, y) -> loop x y)
    end
  in begin
    loop x0 y0;
    result
  end

let connect rows =
  let board = normalize_board rows in
  let h = Array.length board in
  if h = 0 then
    invalid_arg "null board"
  else
    let w = Array.length board.(0) in
    if w = 0 then
      invalid_arg "null board"
    else
      let board = extend_board (normalize_board rows) in
      let top_component = component board 0 1 in
      if top_component.(h + 1).(1) then
        Some O
      else
        let left_component = component board 1 0 in
        if left_component.(1).(w + 1) then
          Some X
        else
          None

Tags:

construct:add
construct:array
construct:assignment
construct:boolean
construct:begin-end
construct:char
construct:comment
construct:constructor
construct:curried-function
construct:field
construct:filter-map
construct:functor
construct:if-then-else
construct:indexing
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:let
construct:list
construct:logical-and
construct:logical-or
construct:method
construct:named-argument
construct:number
construct:parameter
construct:pattern-matching
construct:recursion
construct:string
construct:subtract
construct:tuple
construct:type
construct:union
construct:variable-shadowing
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:boolean-logic
technique:higher-order-functions
technique:looping
technique:recursion

[iHiD]

Exercise: meetup

Code

open Core_kernel

type schedule = First | Second | Third | Fourth | Teenth | Last

type weekday = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday

type date = (int * int * int)

let get_day_of_week weekday =
  match weekday with
  | Monday -> Day_of_week.Mon
  | Tuesday -> Day_of_week.Tue
  | Wednesday -> Day_of_week.Wed
  | Thursday -> Day_of_week.Thu
  | Friday -> Day_of_week.Fri
  | Saturday -> Day_of_week.Sat
  | Sunday -> Day_of_week.Sun

let create_date y m d =
  try Some (Date.create_exn ~y: y ~m: m ~d: d)
  with _ -> None

let to_y_m_d (date_option: Date.t option): (int * int * int) =
  match date_option with
  | Some date -> (Date.year date, Date.month date |> Month.to_int, Date.day date)
  | None -> (0, 0, 0)

let find_date_with_day_of_month (year: int) (month_index: int) (weekday: weekday) (monthday_start: int) (monthday_end: int): Date.t option =
  let day_of_week = get_day_of_week weekday in
  let month = Month.of_int_exn month_index in
  let days = List.range monthday_start monthday_end ~stop: `inclusive in
  List.find_map days ~f: (fun d ->
      match create_date year month d with
      | Some date -> if (Date.day_of_week date) = day_of_week then Some date else None
      | None -> None
    )

let dates_with_weekday year month day_of_week =
  List.range 1 31 ~stop: `inclusive
  |> List.filter_map ~f: (fun d ->
    match create_date year month d with
    | None -> None
    | Some date -> if (Date.day_of_week date) = day_of_week then Some date else None
    )

let with_weekday_in_week (year: int) (month_index: int) (weekday: weekday) (week_index: int): Date.t option =
  let day_of_week = get_day_of_week weekday in
  let month = Month.of_int_exn month_index in
  let dates = dates_with_weekday year month day_of_week in
  List.nth dates week_index

let last_weekday year month_index weekday =
  let day_of_week = get_day_of_week weekday in
  let month = Month.of_int_exn month_index in
  dates_with_weekday year month day_of_week
  |> List.last

let meetup_day schedule weekday ~year: y ~month: m =
  match schedule with
  | First -> with_weekday_in_week y m weekday 0 |> to_y_m_d
  | Second -> with_weekday_in_week y m weekday 1 |> to_y_m_d
  | Third -> with_weekday_in_week y m weekday 2 |> to_y_m_d
  | Fourth -> with_weekday_in_week y m weekday 3 |> to_y_m_d
  | Teenth -> find_date_with_day_of_month y m weekday 13 19 |> to_y_m_d
  | Last -> last_weekday y m weekday |> to_y_m_d

Tags:

construct:if-then-else
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:list
construct:match
construct:named-argument
construct:number
construct:option
construct:parameter
construct:pattern-matching
construct:pipe-forward
construct:tuple
construct:type-alias
construct:try-with
construct:underscore
construct:variant-constructor
construct:variable
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:exceptions
technique:higher-order-functions
uses:List.t
uses:Option.t
uses:Tuple

[iHiD]

Exercise: react

Code

open Core

type callback_id = int

let latest_callback_id: callback_id ref = ref 0
let latest_cell_id = ref 0

type 'a cell_type = 
  InputCell
| ComputeCell of {one: 'a cell; f: 'a -> 'a;}
| ComputeCell2 of {one: 'a cell; two: 'a cell; f: 'a -> 'a -> 'a;}
and 'a cell = {
  cell_id: int;
  eq: 'a -> 'a -> bool;
  value: 'a ref;
  callbacks: (callback_id, ('a -> unit)) Hashtbl.t; 
  cell_type: 'a cell_type;
  observers: 'a cell list ref;
  }

let next_cell_id () =
  let cell_id = !latest_cell_id in
  latest_cell_id := succ !latest_cell_id;
  cell_id

let apply x f = f x

let callbacks_tbl = Int.Table.create

let value_of {value; _}: 'a = !value

let create_input_cell ~(value: 'a) ~eq = 
  let cell_id = next_cell_id () in
  latest_cell_id := succ !latest_cell_id;
  {
    cell_id;
    eq = eq;
    value = ref value;
    callbacks = callbacks_tbl (); 
    cell_type = InputCell;
    observers = ref [];
  }

let add_callback cell ~k = 
  let id = !latest_callback_id in
  Hashtbl.set cell.callbacks ~key:id ~data:k;
  latest_callback_id := succ id;
  id

let remove_callback cell id = 
  Hashtbl.remove cell.callbacks id;;

let call_callbacks cell =
  Hashtbl.iter cell.callbacks ~f:(apply !(cell.value));;

let dedup_cells (cells: 'a cell list): 'a cell list = 
  List.dedup cells ~compare:(fun c1 c2 -> Int.compare c1.cell_id c2.cell_id)

let update_compute_cell_value (cell: 'a cell) = 
  let computed = match cell.cell_type with
  | ComputeCell {one; f} -> f !(one.value)
  | ComputeCell2 {one; two; f} -> f !(one.value) !(two.value)
  | InputCell -> failwith "cannot call update_compute_cell on an input cell";
  in
  if cell.eq !(cell.value) computed
  then false
  else begin
    cell.value := computed;
    true
  end

let breadth_first_update_compute_cells (cell: 'a cell): 'a cell list =
  let update c = List.filter !(c.observers) ~f:update_compute_cell_value in
  let rec go cells acc =
    let updates = dedup_cells (List.concat_map ~f:update cells) in
    if List.is_empty updates
    then acc
    else go updates (updates @ acc)
  in
  go [cell] [cell]

let set_value (cell: 'a cell) (x: 'a) = match cell.cell_type with
| InputCell -> 
    if not (cell.eq !(cell.value) x)
    then begin
      cell.value := x;
      let cells = breadth_first_update_compute_cells cell |> dedup_cells in
      List.iter cells ~f:call_callbacks;
      ()
    end
| _ -> failwith "cannot set the value of a compute cell";;

let create_compute_cell_1 one ~f ~eq = 
  let callbacks = callbacks_tbl () in
  let value = ref (f !(one.value)) in
  let c = {cell_id = next_cell_id(); value; callbacks; observers = ref []; eq; cell_type = ComputeCell {one; f}} in
  one.observers := c :: !(one.observers);
  c

let create_compute_cell_2 one two ~f ~eq = 
  let callbacks = callbacks_tbl () in
  let value = ref (f !(one.value) !(two.value)) in
  let c = {cell_id = next_cell_id(); value; callbacks; observers = ref []; eq; cell_type = ComputeCell2 {one; two; f}} in
  one.observers := c :: !(one.observers);
  two.observers := c :: !(two.observers);
  c

Tags:

construct:assignment
construct:begin
construct:boolean
construct:constructor
construct:dictionary
construct:field-initializer
construct:functor
construct:if-then-else
construct:int
construct:integral-number
construct:invocation
construct:label
construct:list
construct:match
construct:named-argument
construct:option
construct:parameter
construct:pattern-matching
construct:record
construct:reference
construct:string
construct:suspendable-function
construct:table
construct:type
construct:type-alias
construct:underscore
construct:variant
construct:visibility-modifiers
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:higher-order-functions
technique:recursion
uses:Hashtbl
uses:List
uses:Table

[iHiD]

Exercise: react

Code

open Base 
open Base.Ref 

type callback_id = int

type ('a, 'b) cell_kind =
    | Input of ('a ref)
    | Compute_1 of ('b ref) * ('a -> 'a)
    | Compute_2 of ('b ref) * ('b ref) * ('a -> 'a -> 'a)

type 'a cell = { 
    id: int;
    eq: ('a -> 'a -> bool) ref; 
    callbacks: (((callback_id ref) * (('a -> unit) ref)) list) ref;
    kind: ('a, 'a cell) cell_kind;
    refs: ((('a cell) ref) list) ref;
} 

let rec value_of { kind; _ } =
    match kind with 
    | Input v -> !v
    | Compute_1 (c, f) -> f (value_of !c)
    | Compute_2 (c1, c2, f) -> f (value_of !c1) (value_of !c2)

let create_id =
  let n = ref 0 in
  fun () ->
    let id = !n in
    Int.incr n;
    id

let create_input_cell ~value ~eq = {
    id = create_id ();
    eq = ref eq; 
    callbacks = ref []; 
    kind = Input (ref value);
    refs = ref [];
}

let create_compute_cell_1 c ~f ~eq = 
    let compute_cell = {
        id = create_id ();
        eq = ref eq; 
        callbacks = ref [];
        kind = (Compute_1 (ref c, f));
        refs = ref [];
    }
    in 
    c.refs := (ref compute_cell) :: !(c.refs);
    compute_cell

let create_compute_cell_2 c1 c2 ~f ~eq = 
    let compute_cell = {
        id = create_id ();
        eq = ref eq; 
        callbacks = ref [];
        kind = Compute_2 (ref c1, ref c2, f); 
        refs = ref [];
    }
    in 
    c1.refs := (ref compute_cell) :: !(c1.refs);
    c2.refs := (ref compute_cell) :: !(c2.refs);
    compute_cell

let add_callback { callbacks; _ } ~k =
    let id = create_id () in
    callbacks := (ref id, ref k) :: !callbacks;
    id

let remove_callback { callbacks; _ } id =
    callbacks := List.filter ~f:(fun (i, _) -> if !i <> id then true else false ) !callbacks;
    ()

let cell_val_eq cell v = 
    !(cell.eq) v (value_of cell)

let callbacks_do cell =
    let already_called = ref [] in
    let do_call id = 
        match List.find ~f:(fun t -> t = !id) !already_called with
        | None -> already_called := !id::!already_called; true 
        | _ -> false 
    in
    List.iter ~f:(fun (id, f) -> if do_call id then !f (value_of cell) else ()) !(cell.callbacks)

let iterate_cell_callbacks cells_with_vals = 
    let already_called = ref [] in 
    let called id = 
        match List.find ~f:(fun t -> t = id) !already_called with
        | None -> already_called := id::!already_called; false 
        | _ -> true 
    in
    List.iter ~f:(fun (old_val, cell) -> if (cell_val_eq cell old_val) || (called cell.id) then () else callbacks_do cell) cells_with_vals 

let ref_cells_with_vals cell_top = 
    let refs = ref [] in
    let rec loop cell_param = 
        match !(cell_param.refs) with
        | [] -> ()
        | cells_matched -> refs := List.append !refs cells_matched; List.iter ~f:(fun cell -> loop !cell) cells_matched
    in loop cell_top;
    List.map ~f:(fun c -> ((value_of !c), !c)) !refs

let set_value cell new_value =
    let cells_with_vals = 
        match cell.kind with 
        | Input v -> Some(v, (!v, cell)::(ref_cells_with_vals cell))
        | _ -> None
    in 
    match (cells_with_vals) with 
    | Some(v, cells) -> if !(cell.eq) !v new_value then () else v := new_value; iterate_cell_callbacks cells
    | None -> ()

Tags:

construct:boolean
construct:if-then-else
construct:int
construct:integral-number
construct:invocation
construct:label
construct:list
construct:logical-or
construct:match
construct:named-argument
construct:pattern-matching
construct:record
construct:reference
construct:recursive-function
construct:type
construct:underscore
construct:variant
construct:variable
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:boolean-logic
technique:higher-order-functions
technique:looping
uses:List

[iHiD]

Exercise: hexadecimal

Code

open Core.Std
let mp = [('0', 0); ('1', 1); ('2', 2);
          ('3', 3); ('4', 4); ('5', 5); ('6', 6);
          ('7', 7); ('8', 8); ('9', 9); ('a', 10);
          ('b', 11); ('c', 12); ('d', 13); ('e', 14);
          ('f', 15)]

let to_int (s : string) : int =
  let rec innerfun xs multi acc =
    match xs with
    | [] -> acc
    | x :: xs' ->
       match List.find mp (fun (y, _) -> y = x) with
       | Some (_, v) -> innerfun xs' (multi * 16) (v * multi + acc)
       | None -> innerfun [] 0 0
  in innerfun (List.rev (String.to_list s)) 1 0

Tags:

construct:add
construct:char
construct:empty-list
construct:functor
construct:implicit-conversion
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:let-binding
construct:list
construct:match-expression
construct:multiply
construct:number
construct:parameter
construct:recursion
construct:string
construct:tuple
construct:underscore
construct:value-binding
paradigm:functional
paradigm:object-oriented
technique:higher-order-functions
technique:recursion

[iHiD]

Exercise: allergies

Code

open Base 

type allergen = Eggs
              | Peanuts
              | Shellfish
              | Strawberries
              | Tomatoes
              | Chocolate
              | Pollen
              | Cats

let allergen_eq a b = 
    match a, b with
    | Eggs, Eggs -> true 
    | Peanuts, Peanuts -> true 
    | Shellfish, Shellfish -> true 
    | Strawberries, Strawberries -> true 
    | Tomatoes, Tomatoes -> true 
    | Chocolate, Chocolate -> true 
    | Pollen, Pollen -> true 
    | Cats, Cats -> true 
    | _ -> false 

let allergen_map = 
    Map.of_alist_exn (module Int) 
    [
    (1, Eggs); 
    (2, Peanuts); 
    (4, Shellfish); 
    (8, Strawberries); 
    (16, Tomatoes); 
    (32, Chocolate); 
    (64, Pollen); 
    (128, Cats);
    ]

let allergies i =
    if i = 0 then [] else 
    let (_, res) = 
        Map.fold_right allergen_map 
        ~init:(i, []) 
        ~f:(fun ~key:k ~data:v (count, acc) -> if count >= k then (count - k, v::acc) else (count, acc))
    in 
    res

let allergic_to i a =
    match allergies i |> List.find ~f:(fun b -> allergen_eq a b) with
    | Some(_) -> true
    | _ -> false 

Tags:

construct:assignment
construct:boolean
construct:if-then-else
construct:int
construct:integral-number
construct:invocation
construct:lambda
construct:list
construct:match
construct:parameter
construct:pattern-matching
construct:pipe-forward
construct:subtract
construct:tuple
construct:type
construct:variant
construct:visibility-modifiers
paradigm:functional
paradigm:imperative
paradigm:object-oriented
technique:higher-order-functions

[ErikSchierboom]

This is an automated comment

Hello :wave: Next week we're going to start using the tagging work people are doing on these. If you've already completed the work, thank you! If you've not, but intend to this week, that's great! If you're not going to get round to doing it, and you've not yet posted a comment letting us know, could you please do so, so that we can find other people to do it. Thanks!