diff --git a/lib/std.nh b/lib/std.nh index f3c8d17..c0b1634 100644 --- a/lib/std.nh +++ b/lib/std.nh @@ -8,14 +8,75 @@ extern "support.hpp" "std" "to_string" fun StringOfInt int -> string extern "support.hpp" "std" "pow" fun Pow float float -> float +/* + +type key_signature = { + scale = { 261.63, 293.66, 329.63, 349.23, 392.00, 440.00, 493.88 } +} + +type time_signature = { + upper = 4 + lower = 4 +} + +type pitch = { + rank = 1 + octave = 0 + offset = 0 +} + +type chord = { + pitches = pitch[] +} + +type track = { + key_signature = init key_signature + time_signature = init time_signature + chords = chord[] + durations = float[] +} + +fun IsMember l x = ( + b = false + for item in l + do b = b || (item == x) + b +) +fun ChordOfPitch pitch = init chord { pitches = [pitch] } +fun PitchOfInt i = init pitch { rank = i } +fun AddPitchOctave pitch octaves = ( pitch$octave = pitch$octave + octaves; pitch ) +fun FlatPitch pitch = ( pitch$offset = pitch$offset - 1; pitch ) +fun SharpPitch pitch = ( pitch$offset = pitch$offset + 1; pitch ) +fun ChordOfChords c1 c2 = ( + c = chord[] + for pitch in c1$pitches . c2$pitches + do if IsMember c pitch then () else (c = c . [pitch]; ()) + c +) + +fun Rest = init chord + +fun ConcatTracks t1 t2 = { + if t1$key_signature == t2$key_signature && + t1$time_signature == t2$time_signature + then ( + t1$chords = t1$chords . t2$chords + t1$durations = t1$durations . t2$durations + t1 + ) + else throw "Cannot concat tracks with different key or time signature" +} + fun PrintEndline str = ( Print str Print "\n" ) -/* +*/ -include std_basic + + +/* key_signature = init key_signature time_signature = init time_signature @@ -23,45 +84,45 @@ tempo = 120 fun Scale pitch_start pitch_end = ( - // TODO: interpolate between pitches + // TODO: interpolate between pitches ) fun Arpeggio chord = ( - // TODO: unpack chord into music array + // TODO: unpack chord into music array ) fun Rhythm track = ( - // TODO: get rhythm from track + // TODO: get rhythm from track ) fun Chords track = ( - // TODO: get chords from track + // TODO: get chords from track ) // TODO: unlimited args option fun Parallel *tracks = ( - // TODO: return song object with tracks aligned in parallel + // TODO: return song object with tracks aligned in parallel ) fun Sequential *tracks = ( - // TODO: return song object with tracks aligned sequentially + // TODO: return song object with tracks aligned sequentially ) fun Length track = ( - // TODO: return length of track in terms of duration + // TODO: return length of track in terms of duration ) fun Extend length track = ( - // TODO: repeat track for up to length duration + // TODO: repeat track for up to length duration ) fun StartWith track base_track = ( - + ) fun EndWith track base_track = ( diff --git a/src/ast.ml b/src/ast.ml index 97f61da..18dfa26 100644 --- a/src/ast.ml +++ b/src/ast.ml @@ -37,7 +37,7 @@ type expr = | Block of expr list | Conditional of expr * expr * expr | For of string * expr * expr - | Throw of expr * expr + | Throw of expr | Assign of var_reference * expr | StructInit of string * expr list @@ -102,7 +102,7 @@ let rec string_of_expr e = | ArrIdx (x, y) -> String.concat " " [ x; ".("; string_of_expr y; ")" ] | Arr(x) -> String.concat " " [ "["; string_of_exp_list x; "]" ] | ArrMusic(x) -> String.concat " " [ "{"; string_of_exp_list x; "}" ] - | Throw(x, y) -> String.concat " " ["Throw"; string_of_expr x; string_of_expr y] + | Throw(x) -> String.concat " " ["Throw"; string_of_expr x] and string_of_exp_list l = match l with | [] -> "" diff --git a/src/cast.ml b/src/cast.ml index dfedd30..a0a9e76 100644 --- a/src/cast.ml +++ b/src/cast.ml @@ -2,7 +2,7 @@ open Core.Std open Ast -type binary_operator = Add | Sub | Mult | Div | Equal | Neq | Less | Leq | Greater | Geq +type binary_operator = Add | Sub | Mult | Div | Mod | Equal | Neq | Less | Leq | And | Or type unary_operator = Not | Neg type decl = Ast.t * string @@ -91,7 +91,7 @@ let rec string_of_expr = function (match o with | Add -> "+" | Sub -> "-" | Mult -> "*" | Div -> "/" | Equal -> "==" | Neq -> "!=" - | Less -> "<" | Leq -> "<=" | Greater -> ">" | Geq -> ">=") ^ " " ^ + | Less -> "<" | Leq -> "<=" | Mod -> "%" | And -> "&&" | Or -> "||") ^ " " ^ string_of_expr e2 | Uniop(o, e) -> (match o with Not -> "!" | Neg -> "-") ^ string_of_expr e | Assign(v, e) -> string_of_expr (VarRef(v)) ^ " = " ^ string_of_expr e diff --git a/src/cpp_sast.ml b/src/cpp_sast.ml index 8d6583b..670ee63 100644 --- a/src/cpp_sast.ml +++ b/src/cpp_sast.ml @@ -14,11 +14,37 @@ let rec castx_of_sastx texpr = | Sast.LitStr(x) -> Cast.LitStr(x) | Sast.LitUnit -> Cast.LitUnit - | Sast.Binop(lexpr, op, rexpr) - -> ignore lexpr; ignore op; ignore rexpr; failwith "Binop cast_sast not implemented" + | Sast.Binop(lexpr, op, rexpr) -> + begin match op with + | Ast.Zip -> failwith "Internal error: binop zip should have been converted to Call NhFunction in ast2sast" + | Ast.Concat -> + Cast.Call(Cast.Function("nh_support","concat"),[castx_of_sastx lexpr; castx_of_sastx rexpr]) + | Ast.Chord -> failwith "Internal error: binop chord should have been converted to Call NhFunction in ast2sast" + | Ast.Octave -> failwith "Internal error: binop octave should have been converted to Call NhFunction in ast2sast" + | _ as cop -> let op = begin match cop with + | Ast.Add -> Cast.Add + | Ast.Sub -> Cast.Sub + | Ast.Mul -> Cast.Mult + | Ast.Div -> Cast.Div + | Ast.Mod -> Cast.Mod + | Ast.Eq -> Cast.Equal + | Ast.Neq -> Cast.Neq + | Ast.Lt -> Cast.Less + | Ast.Lte -> Cast.Leq + | Ast.And -> Cast.And + | Ast.Or -> Cast.Or + | _ -> failwith "Internal error: failed to match all possible binops in sast2cast" + end in Cast.Binop(castx_of_sastx lexpr, op, castx_of_sastx rexpr) + end + - | Sast.Uniop(op, expr) - -> ignore op; ignore expr; failwith "Uniop cast_sast not implemented" + | Sast.Uniop(op, expr) -> + begin match op with + | Ast.Not -> Cast.Uniop(Cast.Not, castx_of_sastx expr) + | Ast.Neg -> Cast.Uniop(Cast.Neg, castx_of_sastx expr) + | _ -> failwith + "Internal error: uniop flat and sharp should have been converted to Call NhFunction in ast2sast" + end | Sast.VarRef(names) -> Cast.VarRef(names) diff --git a/src/parser.mly b/src/parser.mly index 02a97e2..fb22e69 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -143,7 +143,7 @@ expr: | expr CONCAT expr { Binop($1, Concat, $3) } | ID_VAR DOT_LPAREN expr RPAREN { ArrIdx($1, $3) } | control { $1 } -| THROW non_apply non_apply { Throw($2, $3) } +| THROW non_apply { Throw($2) } control: | IF sep_expr_sep THEN sep_expr_sep ELSE sep_star expr { Conditional($2,$4,$7) } diff --git a/src/sast.ml b/src/sast.ml index feb8875..117020e 100644 --- a/src/sast.ml +++ b/src/sast.ml @@ -23,7 +23,7 @@ type expr_detail = | Block of expr_typed list | Conditional of expr_typed * expr_typed * expr_typed | For of new_variable_name * expr_typed * expr_typed - | Throw of expr_typed * expr_typed + | Throw of expr_typed | Init of new_variable_name * expr_typed | Assign of variable_name * expr_typed | Struct of type_name * ((string * expr_typed) list) diff --git a/src/typed_ast.ml b/src/typed_ast.ml index e5d7c9d..62463a4 100644 --- a/src/typed_ast.ml +++ b/src/typed_ast.ml @@ -106,6 +106,17 @@ let check_unique_functions fundefs externs = else nfundef :: defs ) +let chord_of sexpr = + begin match sexpr with + (* use function in standard library on chordable (chord, pitch, int) exprs *) + | (_, Ast.Int) -> Sast.FunApply(Sast.NhFunction("ChordOfPitch"), + [ Sast.FunApply(Sast.NhFunction("PitchOfInt"), [(Sast.LitInt(0),Ast.Int)]), + Ast.Type("pitch") ]) + | (_, Ast.Type("pitch")) -> Sast.FunApply(Sast.NhFunction("ChordOfPitch"), [sexpr]) + | (expr, Ast.Type("chord")) -> expr + | _ -> failwith "This expression is not chordable" + end, Ast.Type("chord") + let rec sast_expr env tfuns_ref = function | Ast.LitBool(x) -> Sast.LitBool(x), Ast.Bool | Ast.LitInt(x) -> Sast.LitInt(x), Ast.Int @@ -133,43 +144,32 @@ let rec sast_expr env tfuns_ref = function | Ast.And | Ast.Or -> failwith "This operation is only defined for bool" | Ast.Concat -> begin match lt, rt with - (* disallow chords to be concatted *) - | Ast.Array(l), Ast.Array(r) - when l = r && l <> Ast.Type("pitch") -> - Sast.Binop(lexprt,op,rexprt), lt - (* note that track is a type, not array *) - | Ast.Type("track"), Ast.Type("track") - -> Sast.Binop(lexprt,op,rexprt), lt - | _ -> failwith "This operation is only defined for same nonprimitive types" end - | Ast.Chord -> begin match lt, rt with - (* chordOp can be with pitch or chord or int *) - | Ast.Array(Ast.Type("pitch")), Ast.Array(Ast.Type("pitch")) - | Ast.Type("pitch"), Ast.Array(Ast.Type("pitch")) - | Ast.Array(Ast.Type("pitch")), Ast.Type("pitch") - | Ast.Type("pitch"), Ast.Type("pitch") - | Ast.Int, Ast.Array(Ast.Type("pitch")) - | Ast.Array(Ast.Type("pitch")), Ast.Int - | Ast.Int, Ast.Type("pitch") - | Ast.Type("pitch"), Ast.Int - | Ast.Int, Ast.Int - -> Sast.Binop(lexprt,op,rexprt), Ast.Array(Ast.Type("pitch")) - | _ -> failwith "This operation is only defined for pitch, chord, or int" end - | Ast.Octave -> begin match lt, rt with - | Ast.Type("pitch"), Ast.Int - | Ast.Int, Ast.Int -> Sast.Binop(lexprt,op,rexprt), Ast.Type("pitch") - | _ -> failwith "This operation is only defined for [pitch int] and int" end - | Ast.Zip -> begin match lt, rt with - (* zip works with music arr, chord, pitch, or int/float *) - | Ast.Float, Ast.Int - | Ast.Float, Ast.Type("pitch") - | Ast.Float, Ast.Array(Ast.Type("pitch")) - | Ast.Float, Ast.Array(Ast.Array(Ast.Type("pitch"))) - | Ast.Array(Ast.Float), Ast.Int - | Ast.Array(Ast.Float), Ast.Type("pitch") - | Ast.Array(Ast.Float), Ast.Array(Ast.Type("pitch")) - | Ast.Array(Ast.Float), Ast.Array(Ast.Array(Ast.Type("pitch"))) - -> Sast.Binop(lexprt,op,rexprt), Ast.Type("track") - | _ -> failwith "Incorrect types for zip" end + (* also allow tracks to be concatted *) + | Ast.Type("track"), Ast.Type("track") -> Sast.FunApply(NhFunction("ConcatTracks"),[lexprt;rexprt]), lt + | Ast.Array(l), Ast.Array(r) when l = r -> Sast.Binop(lexprt,op,rexprt), lt + | _ -> failwith "Concat is only for defined for same typed arrays and tracks" end + + | Ast.Chord -> + (* guarantee that chord binop is between two chords *) + Sast.FunApply(NhFunction("ChordOfChords"),[chord_of lexprt; chord_of rexprt]), Ast.Type("chord") + + | Ast.Octave -> + let lexprt = match lt with + | Ast.Type("pitch") -> lexprt + | Ast.Int -> Sast.FunApply(NhFunction("PitchOfInt"), [lexprt]), Ast.Type("pitch") + | _ -> failwith "octave only defined for pitch or int on left side" + in if rt = Ast.Int + then Sast.FunApply(NhFunction("AddPitchOctave"), [lexprt;rexprt]), Ast.Type("pitch") + else failwith "octave only defined for int on right side" + + | Ast.Zip -> + if (lt = Ast.Float || lt = Ast.Array(Ast.Float)) + then let rexprt = match rt with + (* either chord or array of chord is valid for zip *) + | Ast.Array(Ast.Type("chord")) -> rexprt + | _ -> chord_of rexprt + in Sast.Binop(lexprt,op,rexprt), Ast.Type("track") + else failwith "left side expression of zip must of float or array of float" end | Ast.Uniop(op, expr) -> let exprt = sast_expr env tfuns_ref expr in @@ -183,7 +183,19 @@ let rec sast_expr env tfuns_ref = function | Ast.Sharp | Ast.Flat when t = Ast.Int || t = Ast.Type("pitch") -> Sast.Uniop(op, exprt), Ast.Type("pitch") - |Ast.Sharp | Ast.Flat -> failwith "This operator is only defined for int or pitch" + + | Ast.Sharp -> let tpitch = Ast.Type("pitch") in + let exprt = match t with + | Ast.Int -> Sast.FunApply(NhFunction("PitchOfInt"), [exprt]), tpitch + | Ast.Type("pitch") -> exprt + | _ -> failwith "sharp is only defined for int or pitch" + in Sast.FunApply(NhFunction("SharpPitch"), [exprt]), tpitch + | Ast.Flat -> let tpitch = Ast.Type("pitch") in + let exprt = match t with + | Ast.Int -> Sast.FunApply(NhFunction("PitchOfInt"), [exprt]), tpitch + | Ast.Type("pitch") -> exprt + | _ -> failwith "flat is only defined for int or pitch" + in Sast.FunApply(NhFunction("FlatPitch"), [exprt]), tpitch end | Ast.FunApply(name, arg_exprs) -> @@ -280,8 +292,8 @@ let rec sast_expr env tfuns_ref = function | For(loop_var_name, items, body) -> ignore (loop_var_name, items, body); failwith "Type checking not implemented for For" - | Throw(retval, msg) -> - ignore (retval, msg); failwith "Type checking not implemented for Throw" + | Throw(msg) -> + ignore msg; failwith "Type checking not implemented for Throw" | Assign(names, expr) -> let (value, tvalue) = sast_expr env tfuns_ref expr in