[F#]Schedule Board (http://www.rumix.com/sb/) のファイルを変換・修復

ConvSch.fsx

// This file is in the public domain.

#r "System"
#r "System.Drawing"
#r "System.Windows.Forms"

open System
open System.IO
open System.Text
open System.Drawing
open System.Windows.Forms

type ExOpt<'a> = ExSome of 'a | ExErr of int

type MaybeErrorBuilder() =
    member this.Bind(x: int * bool, f) =
        if snd x then f() else ExErr (fst x)
    member this.Return(x) = ExSome x

let maybeError = MaybeErrorBuilder()

let readstr (br:BinaryReader) =
    let len = int <| br.ReadByte()
    if len = 0 then "" else
    let len = if len < 255 then len else int <| br.ReadUInt16()
    br.ReadBytes len |> Encoding.Default.GetString

let writestr (bw:BinaryWriter) (s:string) =
    let b = Encoding.Default.GetBytes s
    if b.Length = 0 then
        bw.Write 0uy
    elif b.Length < 255 then
        bw.Write (byte b.Length)
        bw.Write b
    else
        bw.Write 255uy
        bw.Write (uint16 b.Length)
        bw.Write b

type Record() =
    member val Type   = 0  with get, set
    member val Start  = 0L with get, set
    member val End    = 0L with get, set
    member val Modify = 0L with get, set
    member val Color  = 0  with get, set
    member val Index  = 0  with get, set
    member val Text   = "" with get, set
    member val Id     = "" with get, set
    member val User   = "" with get, set
    member val Desc   = "" with get, set

    member r.Write(bw:BinaryWriter) =
        bw.Write 0x12c
        bw.Write 0x50002
        bw.Write r.Type // 0:新規, 1:修正, 2:削除
        bw.Write 0
        bw.Write r.Start
        bw.Write 0
        bw.Write r.End
        bw.Write 0
        bw.Write r.Modify
        bw.Write r.Color
        bw.Write r.Index
        writestr bw r.Text
        writestr bw r.Id
        writestr bw r.User
        writestr bw r.Desc
        bw.Write 0uy

    override r.ToString() =
        sprintf "%d,%d,%d,%d,%d,%d,%d,%d,%d,\"%s\",\"%s\",\"%s\",\"%s\""
            r.Type
            (r.Start  |> int) (r.Start  >>> 32 |> int)
            (r.End    |> int) (r.End    >>> 32 |> int)
            (r.Modify |> int) (r.Modify >>> 32 |> int)
            r.Color r.Index r.Text r.Id r.User r.Desc

    member r.Contains (rr:Record) =
        rr.Type = 0 && r.Id = rr.Id &&
        ((r.Start <= rr.Start && rr.Start <  r.End) ||
         (r.Start <  rr.End   && rr.End   <= r.End))

let readrec (br:BinaryReader) = maybeError {
    let r = Record()
    do! 1, br.ReadInt32() = 0x12c
    do! 2, br.ReadInt32() = 0x50002
    r.Type   <- br.ReadInt32()
    do! 3, br.ReadInt32() = 0
    r.Start  <- br.ReadInt64()
    do! 4, br.ReadInt32() = 0
    r.End    <- br.ReadInt64()
    do! 5, br.ReadInt32() = 0
    r.Modify <- br.ReadInt64()
    r.Color  <- br.ReadInt32()
    r.Index  <- br.ReadInt32()
    r.Text   <- readstr br
    r.Id     <- readstr br
    r.User   <- readstr br
    r.Desc   <- readstr br
    do! 6, br.ReadByte() = 0uy
    return r }

let readsch f =
    use br = new BinaryReader(new FileStream(f, FileMode.Open))
    let ret = new System.Collections.Generic.List<Record>()
    let rec loop() =
        if br.PeekChar() = -1 then 0, 0L else
        let pos = br.BaseStream.Position
        match readrec br with
        | ExErr e ->
            e, pos
        | ExSome r ->
            ret.Add r
            loop()
    match loop() with a, b -> a, b, ret.ToArray()

let writecsv (tw:TextWriter) (recs:Record[]) =
    recs |> Array.iteri (fun num r -> tw.WriteLine("{0},{1}", num, r))

let rebuild (recs:Record[]) =
    let recs = Array.copy recs
    for r in recs do
        match r.Type with
        | 1 ->
            recs.[r.Index].Type <- 3
            r.Type  <- 0
            r.Index <- 0
        | 2 ->
            recs.[r.Index].Type <- 3
        | _ ->
            ()
    recs |> Array.iteri (fun i r ->
        if r.Type = 0 && recs.[i + 1 ..] |> Array.exists r.Contains then
            r.Type <- 4)
    recs |> Array.filter (fun r -> r.Type = 0)

let suffix f sfx =
    let dir = Path.GetDirectoryName f
    let name = Path.GetFileNameWithoutExtension f
    let ext = Path.GetExtension f
    Path.Combine(dir, name + sfx + ext)

let convert f =
    let e, pos, recs = readsch f
    let fout = Path.ChangeExtension(f, ".csv")
    use sw = new StreamWriter(fout, false, Encoding.Default)
    writecsv sw recs
    if e <> 0 then fprintfn sw "error,%d,%x" e pos
    use sw2 = new StreamWriter(suffix fout "-2", false, Encoding.Default)
    let recs2 = rebuild recs
    writecsv sw2 recs2
    use bw = new BinaryWriter(new FileStream(suffix f "-2", FileMode.Create))
    for r in recs2 do r.Write bw

[<EntryPoint; STAThread>] do
let w = new Form(Text = "SCH 変換修復", AllowDrop = true)
w.Controls.Add (new Label(Text = "ここに .sch ファイルを DnD してください。",
                          Dock = DockStyle.Fill,
                          TextAlign = ContentAlignment.MiddleCenter))
w.DragEnter.Add <| fun e ->
    if e.Data.GetDataPresent DataFormats.FileDrop then
        e.Effect <- DragDropEffects.Link
w.DragDrop.Add <| fun e ->
    let files = e.Data.GetData(DataFormats.FileDrop) :?> string[]
    if files <> null then
        files
        |> Array.filter (fun f -> Path.GetExtension(f).ToLower() = ".sch")
        |> Array.iter convert
Application.Run w

csv2sch.bas

Attribute VB_Name = "csv2sch"
Option Explicit

Sub WriteStr(T$)
    Dim L%, LB As Byte, Buf() As Byte
    Buf = StrConv(T, vbFromUnicode)
    L = UBound(Buf) + 1
    If L = 0 Then
        LB = 0
        Put #1, , LB
    ElseIf L < 255 Then
        LB = L
        Put #1, , LB
        Put #1, , Buf
    Else
        LB = 255
        Put #1, , LB
        Put #1, , L
        Put #1, , Buf
    End If
End Sub

Sub SCH生成()
    Dim TMP&, TB As Byte, T&, S1&, S2&, E1&, E2&, M1&, M2&, C&, I&, Tx$, Id$, Us$, Ds$, Y%
    Y = 1
    Open "C:\output.sch" For Binary Lock Write As #1
    While Cells(Y, 1) <> ""
        T = Cells(Y, 2)
        S1 = Cells(Y, 3)
        S2 = Cells(Y, 4)
        E1 = Cells(Y, 5)
        E2 = Cells(Y, 6)
        M1 = Cells(Y, 7)
        M2 = Cells(Y, 8)
        C = Cells(Y, 9)
        I = Cells(Y, 10)
        Tx = Cells(Y, 11)
        Id = Cells(Y, 12)
        Us = Cells(Y, 13)
        Ds = Cells(Y, 14)
        TMP = &H12C: Put #1, , TMP
        TMP = &H50002: Put #1, , TMP
        Put #1, , T
        TMP = 0: Put #1, , TMP
        Put #1, , S1
        Put #1, , S2
        TMP = 0: Put #1, , TMP
        Put #1, , E1
        Put #1, , E2
        TMP = 0: Put #1, , TMP
        Put #1, , M1
        Put #1, , M2
        Put #1, , C
        Put #1, , I
        WriteStr Tx
        WriteStr Id
        WriteStr Us
        WriteStr Ds
        TB = 0: Put #1, , TB
        Y = Y + 1
    Wend
    Close #1
End Sub

make.bat

"C:\Program Files\Microsoft SDKs\F#\3.0\Framework\v4.0\fsc" --standalone --target:winexe ConvSch.fsx