namespace HtmlStruct open AstAccess open System.Xml open System open System.Xml.Linq open System.IO /// 展现节点 ========================================================================================= module Present = /// 内容元素:分卷、章节、引用节点、故事线、情节、定义节点、引用节点 type IDomUnit = interface abstract member name:unit -> string abstract member object:unit -> AstImport.AstObject end /// 容器节点:分卷、章节、故事线、情节 type IContainer = interface abstract member append:IDomUnit list -> IContainer abstract member children:unit -> IDomUnit list end /// 可访问页面 type PageAccess(name: string) = class let mutable root: string = "" member this.pageURL(): string = $"{root}{name}.html" member this.setPageRoot(path: string) = if path.EndsWith "/" then root <- path else root <- path+"/" end /// 内容定义元素 ================================================================================= type Forwards(item: AstImport.AstObject) = class let mutable defines_page: Option = None let mutable assemble_page: Option = None member this.elementID(): string = item.address() /// 节点定义页面,本元素完整URL member this.definedURL(): string = match defines_page with | Some v -> $"{v.pageURL()}#{this.elementID()}" | None -> failwith "节点元素定义页面配置错误" member this.setDefines(page: PageAccess) = defines_page <- Some(page) /// 节点汇集页面,本元素完整URL member this.assembleURL():string = match assemble_page with | Some v -> $"{v.pageURL()}#{this.elementID()}" | None -> failwith "节点元素汇集页面配置错误" member this.setAssemble(page: PageAccess) = assemble_page <- Some(page) end /// 回访定义元素 ================================================================================= type Backwards(bind_item: Forwards, refer_anchor: string) = class member this.defsElement() = bind_item member this.elementID(): string = bind_item.elementID() member this.backwardsLink(): string = bind_item.definedURL() member this.referAnchor(): string = refer_anchor end /// 访问页面:概括页面、卷宗页面、故事线页面、节点汇总 ================================================= type VolumePage(page_name: string, volume: IDomUnit, childs: IDomUnit list) = class inherit PageAccess(page_name) new(page_name, volume) = VolumePage(page_name, volume, []) interface IDomUnit with member this.name():string = volume.name() member this.object() = volume.object() interface IContainer with member this.children(): IDomUnit list = childs member this.append(new_list: IDomUnit list): IContainer = VolumePage(page_name, volume, childs@new_list) end type StoryPage(page_name: string, story: IDomUnit, childs: IDomUnit list) = class inherit PageAccess(page_name) new(page_name, story) = StoryPage(page_name, story, []) interface IDomUnit with member this.name():string = story.name() member this.object() = story.object() interface IContainer with member this.children(): IDomUnit list = childs member this.append(list: IDomUnit list): IContainer = StoryPage(page_name, story, childs@list) end type PointPage(page_name: string, point: IDomUnit, refer_list: IDomUnit list) = class inherit PageAccess(page_name) new(page_name, point) = PointPage(page_name, point, []) member this.defines() = point interface IDomUnit with member this.name():string = point.name() member this.object() = point.object() interface IContainer with member this.children(): IDomUnit list = refer_list member this.append(childs: IDomUnit list): IContainer = PointPage(page_name, point, refer_list @ childs) end /// 内容节点 ========================================================================================= module Content = type TextContent(word: AstImport.TextItem) = class interface Present.IDomUnit with member this.name(): string = "" member this.object() = word end type PointRefer(refs: AstImport.PointRef, items: Present.IDomUnit list) = class inherit Present.Forwards(refs) let ref_signature = $"@{refs.storyRef()}&{refs.sliceRef()}&{refs.pointRef()}" let lines = refs.children() |> List.map (fun x->x.content()) interface Present.IDomUnit with member this.name(): string = ref_signature member this.object() = refs interface Present.IContainer with member this.children(): Present.IDomUnit list = items member this.append(childs: Present.IDomUnit list): Present.IContainer = failwith "append" end let refer_assemble (refn: AstImport.PointRef) : PointRefer = let texts = refn.children() |> List.map (fun dom -> TextContent(dom) :> Present.IDomUnit) PointRefer(refn, texts) type PointDefine(defs: AstImport.PointDef, items: Present.IDomUnit list) = class inherit Present.Forwards(defs) let lines = defs.children() |> List.map (fun x->x.content()) interface Present.IDomUnit with member this.name(): string = defs.name() member this.object() = defs interface Present.IContainer with member this.children(): Present.IDomUnit list = items member this.append(childs: Present.IDomUnit list): Present.IContainer = failwith "append" end let point_assemble (defs: AstImport.PointDef) : PointDefine = let texts = defs.children() |> List.map (fun dom -> TextContent(dom) :> Present.IDomUnit) PointDefine(defs, texts) /// 具有回退功能的元素 type AssembleRefer<'T when 'T :> Present.Forwards and 'T :> Present.IDomUnit and 'T:> Present.IContainer>(item: 'T, refer_anchor: string) = class inherit Present.Backwards(item, refer_anchor) interface Present.IDomUnit with member this.name() = refer_anchor member this.object() = item.object() interface Present.IContainer with member this.children(): Present.IDomUnit list = item.children() member this.append(childs: Present.IDomUnit list): Present.IContainer = failwith "append" end type SliceDefine(defs: AstImport.SliceDef, items: Present.IDomUnit list) = class interface Present.IDomUnit with member this.name(): string = defs.name() member this.object() = defs interface Present.IContainer with member this.children(): Present.IDomUnit list = items member this.append(childs: Present.IDomUnit list): Present.IContainer = failwith "append" end let slice_assemble (defs: AstImport.SliceDef) : SliceDefine = let childs = defs.children() |> List.map(fun data -> match data with | :? AstImport.PointRef as refs -> refer_assemble(refs) | :? AstImport.PointDef as defs -> point_assemble(defs) | :? AstImport.TextItem as text -> TextContent(text) | _ -> failwith "match error" ) SliceDefine(defs, childs) type StoryDefine(defs: AstImport.StoryDef, childs: Present.IDomUnit list) = class interface Present.IDomUnit with member this.name(): string = defs.name() member this.object() = defs interface Present.IContainer with member this.children(): Present.IDomUnit list = childs member this.append(childs: Present.IDomUnit list): Present.IContainer = failwith "append" end let story_assemble (defs: AstImport.StoryDef): StoryDefine = let childs = defs.children() |> List.map(fun data -> match data with | :? AstImport.SliceDef as defs -> slice_assemble(defs) | :? AstImport.TextItem as text -> TextContent(text) | _ -> failwith "match error" ) StoryDefine(defs, childs) type ArticleDefine(defs: AstImport.ArticleDef, childs: Present.IDomUnit list) = class interface Present.IDomUnit with member this.name(): string = defs.name() member this.object() = defs interface Present.IContainer with member this.children(): Present.IDomUnit list = childs member this.append(childs: Present.IDomUnit list): Present.IContainer = failwith "append" end let article_assemble (defs: AstImport.ArticleDef) : ArticleDefine = let childs = defs.children() |> List.map(fun data -> match data with | :? AstImport.TextItem as text -> TextContent(text) | :? AstImport.PointRef as refs -> refer_assemble(refs) | _ -> failwith "match error" ) ArticleDefine(defs, childs) type VolumeDefine(defs: AstImport.VolumeDef, childs: Present.IDomUnit list) = class interface Present.IDomUnit with member this.name(): string = defs.name() member this.object() = defs interface Present.IContainer with member this.children(): Present.IDomUnit list = childs member this.append(news: Present.IDomUnit list): Present.IContainer = VolumeDefine(defs, childs@news) end let volume_assemble (defs: AstImport.VolumeDef): VolumeDefine = let childs = defs.children() |> List.map(fun data -> match data with | :? AstImport.TextItem as text -> TextContent(text) | :? AstImport.ArticleDef as defs -> article_assemble(defs) | _ -> failwith "match error" ) VolumeDefine(defs, childs) type UnitGenerate(root: AstImport.AstObject) = class // ast 节点序列 let forwards_map = AstImport.branch_map_conv(root, root.members()) // 累积结果 let mutable result_nodes: (int*Present.IDomUnit) list = [] interface AstImport.AstVisitor with member this.visit(obj: AstImport.AstObject): bool = let refs_depth = AstImport.depth_seek(forwards_map, obj) let childs = result_nodes |> List.filter (fun (depth, _) -> depth > refs_depth) |> List.map(fun (_, object) -> object) let datas = match obj with | :? AstImport.TextItem as text -> result_nodes@[(refs_depth, TextContent(text) :> Present.IDomUnit)] | :? AstImport.PointRef as refs -> result_nodes@[(refs_depth, PointRefer(refs, childs))] | :? AstImport.PointDef as defs -> result_nodes@[(refs_depth, PointDefine(defs, childs))] | :? AstImport.SliceDef as defs -> result_nodes@[(refs_depth, SliceDefine(defs, childs))] | :? AstImport.StoryDef as defs -> result_nodes@[(refs_depth, StoryDefine(defs, childs))] | :? AstImport.ArticleDef as defs -> result_nodes@[(refs_depth, ArticleDefine(defs, childs))] | :? AstImport.VolumeDef as defs -> result_nodes@[(refs_depth, VolumeDefine(defs, childs))] | :? AstImport.Program -> result_nodes | _ -> failwith "match error" result_nodes <- datas if refs_depth > 0 then result_nodes <- result_nodes |> List.filter(fun (depth, _) -> depth <= refs_depth) true member this.contents() = result_nodes |> List.map(fun (_, obj) -> obj) end /// 内容组装 ========================================================================================= module Assemble = /// 构建页面名称 let page_name_encode(node: Present.IDomUnit): string = let name_seqs = $"{node.name()}_{node.object().address()}".ToCharArray() |> Array.map(fun c-> string(uint16(c))) name_seqs |> Array.reduce(fun a b-> a+b) /// 构建所有卷宗页面 let rec volume_page_assemble (nodes: Present.IDomUnit list): Present.VolumePage list = match nodes with | [] -> [] | _ -> match nodes.Head with | :? Content.VolumeDefine as vole -> let con: Present.IContainer = vole Present.VolumePage(page_name_encode(vole), vole, con.children())::volume_page_assemble(nodes.Tail) | _ -> volume_page_assemble(nodes.Tail) /// 构建所有故事线页面 let rec story_page_assemble (nodes: Present.IDomUnit list): Present.StoryPage list = match nodes with | [] -> [] | _ -> match nodes.Head with | :? Content.StoryDefine as storye -> let con: Present.IContainer = storye Present.StoryPage(page_name_encode(storye), storye, con.children())::story_page_assemble(nodes.Tail) | _ -> story_page_assemble(nodes.Tail) /// 提取point-define和point-refer let rec private point_peers_extract(nodes: Present.IDomUnit list):(Present.IDomUnit option*Present.IDomUnit option*Present.IDomUnit option)list = match nodes with | [] -> [] | _ -> let head_data = nodes.Head match head_data with | :? Content.StoryDefine as story_e -> let con = story_e :> Present.IContainer let items = point_peers_extract(con.children())@point_peers_extract(nodes.Tail) items |> List.map( fun (x, y, z)-> match x with | None -> (Some(story_e :> Present.IDomUnit), y, z) | _ -> (x, y, z) ) | :? Present.StoryPage as story_e -> let con = story_e :> Present.IContainer let items = point_peers_extract(con.children())@point_peers_extract(nodes.Tail) items |> List.map( fun (x, y, z)-> match x with | None -> (Some(story_e :> Present.IDomUnit), y, z) | _ -> (x, y, z) ) | :? Content.VolumeDefine as volume_e -> let con = volume_e :> Present.IContainer let items = point_peers_extract(con.children())@point_peers_extract(nodes.Tail) items |> List.map ( fun (x, y, z) -> match x with | None -> (Some(volume_e), y, z) | _ -> (x, y, z) ) | :? Present.VolumePage as volume_e -> let con = volume_e :> Present.IContainer let items = point_peers_extract(con.children())@point_peers_extract(nodes.Tail) items |> List.map ( fun (x, y, z) -> match x with | None -> (Some(volume_e), y, z) | _ -> (x, y, z) ) | :? Content.SliceDefine as slice_e -> let con = slice_e :> Present.IContainer let items = point_peers_extract(con.children())@point_peers_extract(nodes.Tail) items |> List.map( fun (x, y, z) -> match y with | None -> (x, Some(slice_e:> Present.IDomUnit), z) | _ -> (x, y, z) ) | :? Content.ArticleDefine as article_e -> let con = article_e :> Present.IContainer let items = point_peers_extract(con.children())@point_peers_extract(nodes.Tail) items |> List.map( fun (x, y, z) -> match y with | None -> (x, Some(article_e), z) | _ -> (x, y, z) ) | :? Content.PointRefer as refer_e -> let ast_obj = refer_e :> Present.IDomUnit let refer = ast_obj.object() :?> AstImport.PointRef (None, None, Some(refer_e :> Present.IDomUnit))::point_peers_extract(nodes.Tail) | :? Content.PointDefine as define_e -> let ast_obj = define_e :> Present.IDomUnit (None, None, Some(define_e))::point_peers_extract(nodes.Tail) | _ -> point_peers_extract(nodes.Tail) /// 构建节点汇总页面 /// param nodes volume-pages@story-pages let rec point_page_assemble(pages: Present.IDomUnit list) = let checked_list = pages |> List.filter( fun it -> match it with | :? Present.PageAccess -> true | _ -> false ) if checked_list.Length <> pages.Length then failwith "传入的参数pages必须是PageAccess的子类集合" let points_about= point_peers_extract(pages) // 所有的节点关联定义页面 points_about |> List.iter ( fun (page, midx, deref) -> match deref.Value with | :? Present.Forwards as forwards_elm -> let page_def = page.Value :?> Present.PageAccess forwards_elm.setDefines(page_def) | _ -> failwith "point_peers_extract结果类型错误" ) let refer_nodes = points_about |> List.filter( fun (_, _, n) -> match n.Value with | :? Content.PointRefer -> true | _ -> false ) |> List.map( fun (page_defs, mid_defs, point_refs) -> let refn = point_refs.Value.object() :?> AstImport.PointRef let refer_name = $"{page_defs.Value.name()}&{mid_defs.Value.name()}@" let refs = point_refs.Value :?> Content.PointRefer $"{refn.storyRef()}&{refn.sliceRef()}&{refn.pointRef()}", Content.AssembleRefer(refs, refer_name) ) // 构建节点汇集页面 let pages = points_about |> List.filter( fun (_, _, n) -> match n.Value with | :? Content.PointDefine -> true | _ -> false ) |> List.map ( fun (page_defs, slice_defs, point_defs) -> let defs = point_defs.Value :?> Content.PointDefine let name_seqs = $"{page_defs.Value.name()}&{slice_defs.Value.name()}&{point_defs.Value.name()}" let refer_point = Content.AssembleRefer(defs, name_seqs) let page_assemble = Present.PointPage(page_name_encode(defs), refer_point) defs.setAssemble(page_assemble) name_seqs,page_assemble ) pages |> List.map( fun (key, page_one) -> let page_old = page_one :> Present.IContainer let page_dom = page_one :> Present.IDomUnit let nodes = refer_nodes |> List.filter(fun (k, _) -> k = key) nodes |> List.iter (fun (_, data) -> data.defsElement().setAssemble(page_one)) let p = page_old.append(page_dom::(nodes |> List.map(fun (_, x)->x :> Present.IDomUnit))) p :?> Present.IDomUnit ) type PageText = interface abstract member bindPage:unit ->obj abstract member getHtmlText:unit -> string end type PageMaker<'T when 'T :> Present.PageAccess and 'T :> Present.IDomUnit and 'T :> Present.IContainer>(page: 'T) = class member this.getHtmlDocument(): XmlDocument = let doc = XmlDocument() let doc_type = doc.CreateDocumentType("html", null, null, null) doc.AppendChild(doc_type) |> ignore let html = doc.CreateElement("html") let head = doc.CreateElement("head") let charset = doc.CreateElement("meta") charset.SetAttribute("charset", "UTF-8") head.AppendChild(charset) |> ignore let refresh = doc.CreateElement("meta") refresh.SetAttribute("http-equiv", "refresh") refresh.SetAttribute("content", "5") head.AppendChild(refresh) |> ignore let title = doc.CreateElement("title") title.AppendChild(doc.CreateTextNode(page.name())) |> ignore head.AppendChild(title) |> ignore let style = doc.CreateElement("style") style.AppendChild(doc.CreateTextNode("""body{ background-color:lightgray; } h1 { margin-left:300px; margin-top: 50px; margin-bottom: 30px; } div.outline { max-width:90%; #outline:green dotted thick; margin:auto; display:flex; background-color:#f0f0f0; } div#left-nav { min-width:30%; max-width:30%; # border:1px solid red; # outline:green dotted thick; overflow:clip; padding:20px; background-image: linear-gradient( to right, #e0e0e0 0%, #ffffff 100% ); } div#left-nav p { word-wrap:break-word; text-align:right; } div.content { padding: 5px; padding-left: 20px; max-width: 90%; outline: #e0e0e0 solid 1px; box-shadow: 2px 2px 2px gray; } .content p { word-wrap:break-word; } """)) |> ignore head.AppendChild(style) |> ignore html.AppendChild(head) |> ignore doc.AppendChild(html) |> ignore let body = doc.CreateElement("body") html.AppendChild(body) |> ignore let h1 = doc.CreateElement("h1") h1.AppendChild(doc.CreateTextNode(page.name())) |> ignore body.AppendChild(h1) |> ignore let div_outline = doc.CreateElement("div") div_outline.SetAttribute("class", "outline") body.AppendChild(div_outline) |> ignore let div_nav = doc.CreateElement("div") div_nav.SetAttribute("id", "left-nav") div_outline.AppendChild(div_nav) |> ignore this.initNavigate(div_nav) |> ignore let div_content = doc.CreateElement("div") div_content.SetAttribute("id", "content") div_content.SetAttribute("class", "content") div_outline.AppendChild(div_content) |> ignore this.contentAppend(div_content, page.children()) doc member this.initNavigate(nav: XmlElement):XmlElement = let rec nav_items_expand(nav: XmlElement, items: (Present.IDomUnit option*Present.IDomUnit option*Present.IDomUnit option) list) = match items with | [] -> () | _ -> let doc_o = nav.OwnerDocument let (_, _, head) = items.Head match head.Value with | :? Present.Forwards as fx -> let p = doc_o.CreateElement("p") let a = doc_o.CreateElement("a") a.SetAttribute("href", $"#{fx.elementID()}") a.AppendChild(doc_o.CreateTextNode(head.Value.name())) |> ignore p.AppendChild(a) |> ignore nav.AppendChild(p) |> ignore | :? Present.Backwards as bx -> let p = doc_o.CreateElement("p") let a = doc_o.CreateElement("a") a.SetAttribute("href", $"#{bx.elementID()}") a.AppendChild(doc_o.CreateTextNode(head.Value.name())) |> ignore p.AppendChild(a) |> ignore nav.AppendChild(p) |> ignore | _ -> () nav_items_expand(nav, items.Tail) let objp = page :> obj let point_peers = if (objp :? Present.PointPage) then (objp :?>Present.PointPage).defines()::page.children() |> List.map(fun x-> None, None, Some(x)) else point_peers_extract(page.children()) match point_peers with | [] -> let empty = nav.OwnerDocument.CreateElement("p") empty.AppendChild(nav.OwnerDocument.CreateTextNode("当前文档无索引")) |> ignore nav.AppendChild(empty) |> ignore | _ -> nav_items_expand(nav, point_peers) nav member this.contentAppend(pnode: XmlElement, contents: Present.IDomUnit list) = let vdoc = pnode.OwnerDocument match contents with | [] -> () | _ -> match contents.Head with | :? Content.TextContent -> let text_ast = contents.Head.object() :?> AstImport.TextItem let text_line = contents.Tail |> List.filter( fun content_item-> match content_item with | :? Content.TextContent -> let curr_ast = content_item.object() :?> AstImport.TextItem curr_ast.row() = text_ast.row() | _ -> false ) let one_line = contents.Head::text_line let p = vdoc.CreateElement("p") for t in one_line do let text_content = t.object() :?> AstImport.TextItem let content = text_content.content() p.AppendChild(vdoc.CreateTextNode(content)) |> ignore pnode.AppendChild(p) |> ignore this.contentAppend(pnode, List.skip one_line.Length contents) | :? Content.SliceDefine as slice_defs-> let div_slice = vdoc.CreateElement("div") div_slice.SetAttribute("data-type", "slice") div_slice.SetAttribute("class", "content") let slice_title = vdoc.CreateElement("h3") slice_title.AppendChild(vdoc.CreateTextNode(contents.Head.name())) |> ignore div_slice.AppendChild(slice_title) |> ignore pnode.AppendChild(div_slice) |> ignore let slice_con = slice_defs :> Present.IContainer this.contentAppend(div_slice, slice_con.children()) this.contentAppend(pnode, contents.Tail) | :? Content.ArticleDefine as article_defs -> let div_article = vdoc.CreateElement("div") div_article.SetAttribute("data-type", "article") div_article.SetAttribute("class", "content") let article_title = vdoc.CreateElement("h3") article_title.AppendChild(vdoc.CreateTextNode(contents.Head.name())) |> ignore div_article.AppendChild(article_title) |> ignore pnode.AppendChild(div_article) |> ignore let article_con = article_defs :> Present.IContainer this.contentAppend(div_article, article_con.children()) this.contentAppend(pnode, contents.Tail) | :? Present.PointPage as page_point -> let page_defs = page_point.defines() :?> Content.AssembleRefer this.contentAppend(pnode, [page_defs]) this.contentAppend(pnode, contents.Tail) | :? Present.Forwards as object_defs -> let type_name = match object_defs with | :? Content.PointDefine -> "point" | :? Content.PointRefer -> "refer" | _ -> failwith "type mismatch" let div_forwards = vdoc.CreateElement("div") div_forwards.SetAttribute("data-type", type_name) div_forwards.SetAttribute("class", "content") let define_title = vdoc.CreateElement("h3") define_title.AppendChild(vdoc.CreateTextNode(contents.Head.name())) |> ignore div_forwards.AppendChild(define_title) |> ignore let define_a = vdoc.CreateElement("a") define_a.SetAttribute("id", object_defs.elementID()) define_a.SetAttribute("href", object_defs.assembleURL()) define_a.AppendChild(define_title) |> ignore div_forwards.AppendChild(define_a) |> ignore pnode.AppendChild(div_forwards) |> ignore let point_con = contents.Head :?> Present.IContainer this.contentAppend(div_forwards, point_con.children()) this.contentAppend(pnode, contents.Tail) | :? Present.Backwards as object_backs -> let div_backwards = vdoc.CreateElement("div") div_backwards.SetAttribute("data-type", "assemble") div_backwards.SetAttribute("class", "content") let define_title = vdoc.CreateElement("h3") define_title.AppendChild(vdoc.CreateTextNode(contents.Head.name())) |> ignore div_backwards.AppendChild(define_title) |> ignore let define_a = vdoc.CreateElement("a") define_a.SetAttribute("id", object_backs.elementID()) define_a.SetAttribute("href", object_backs.backwardsLink()) define_a.AppendChild(define_title) |> ignore div_backwards.AppendChild(define_a) |> ignore pnode.AppendChild(div_backwards) |> ignore let point_con = contents.Head :?> Present.IContainer this.contentAppend(div_backwards, point_con.children()) this.contentAppend(pnode, contents.Tail) | _ -> () interface PageText with member this.bindPage():obj = page member this.getHtmlText(): string = let doc = this.getHtmlDocument() let out = new StringWriter() let writer = new XmlTextWriter(out) writer.Formatting = Formatting.Indented |> ignore doc.WriteTo(writer) writer.Flush() out.ToString() end