I'm sending dom.apl from my apl-library (it needs work) together with
the libraries it copys. The function dom∆parse is slow and a memory
hog. You probably should say it should be rewritten in C and I would
agree. Each time I've thought about it, I laid down, put a hot compress
over my eyes until the thought went away.
w
#! /usr/local/bin/apl --script
⍝ Rewrite dom∆parse∆openElm to deal with closed element tags <tag/>
⍝ ********************************************************************
⍝ dom.apl Partial implementation of the Document Object Model
⍝ Copyright (C) 2019 Bill Daly
⍝ This program is free software: you can redistribute it and/or modify
⍝ it under the terms of the GNU 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 General Public License for more details.
⍝ You should have received a copy of the GNU General Public License
⍝ along with this program. If not, see <http://www.gnu.org/licenses/>.
⍝ ********************************************************************
)copy 1 utl
)copy 1 lex
)copy 1 stack
⍝ ********************************************************************
⍝
⍝ Create objects
⍝
⍝ ********************************************************************
∇attr←parent dom∆createAttribute name;value
⍝⍝ Function creates an element attribute
→(2=⍴name)/double
utl∆es (~utl∆stringp name)/name,' is not a valid attribute name.'
→single
single:
value←dom∆TRUE
→make
double:
utl∆es (~∧/(2=⍴name),utl∆stringp ¨ name)/'''',name,''' is not a valid
attribute'
value←2⊃name
name←1⊃name
make:
attr←dom∆createNode name
attr[2]←⊂(2⊃attr) lex∆assign 'nodeType' dom∆ATTRIBUTE_NODE
attr[2]←⊂(2⊃attr) lex∆assign 'nodeValue' value
∇
∇node← dom∆createComment txt
node← dom∆createNode 'Comment'
node[2]←⊂(⊃node[2]) lex∆assign 'nodeType' dom∆COMMENT_NODE
node[2]←⊂(⊃node[2]) lex∆assign 'nodeValue' txt
∇
∇docNode← dom∆createDocument rootName;rootNode;typeNode;uri;dn
⍝⍝ Function to create a document. If root name is a nested vector
⍝⍝ rootName[1] is the document qualifiedName and rootName[2] is its
⍝⍝ URI. Left argument docType is optional and if ommitted will be deduced.
docNode← dom∆createNode 'Document'
docNode←docNode dom∆node∆setNodeType dom∆DOCUMENT_NODE
→0
∇
∇documentTypeNode← dom∆createDocumentType rootName;dt
→((2=≡rootName)∧2=⍴rootName)/create
rootName←' ' utl∆split rootName
create:
documentTypeNode←dom∆createNode ⊃rootName[1]
dt←(⊃documentTypeNode[2]) lex∆assign 'nodeType' dom∆DOCUMENT_TYPE_NODE
dt←dt lex∆assign (⊂'nodeValue'), ⊂rootName[1]
→(1=⍴rootName)/end
dt←dt lex∆assign 2↑1↓rootName,dom∆TRUE
end:
documentTypeNode[2]←⊂dt
→0
∇
∇elementNode← dom∆createElement name;en
elementNode← dom∆createNode name
en←(⊃elementNode[2]) lex∆assign 'nodeType' dom∆ELEMENT_NODE
elementNode[2]←⊂en lex∆assign 'attributes' dom∆createNamedNodeMap
∇
∇node←dom∆createTextNode txt;attrs
node← dom∆createNode '#text#'
attrs←(⊃node[2]) lex∆assign 'nodeType' dom∆TEXT_NODE
node[2]←⊂attrs lex∆assign 'nodeValue' txt
∇
∇pi←dom∆createProcessingInstruction txt;b;target;data;pn
⍝⍝ Function creates processor specific instructions node
txt←utl∆clean txt
target←(b←∧\txt≠' ')/txt
data←1↓(~b)/txt
pi← dom∆createNode target
pn←(⊃pi[2]) lex∆assign 'nodeType' dom∆PROCESSING_INSTRUCTION_NODE
pn←pn lex∆assign 'target' target
pi[2]←⊂pn lex∆assign 'data' data
∇
∇node← dom∆createNode name
⍝⍝ Fn creates a DOM node
node←lex∆init
node←node lex∆assign 'nodeName' name
node←node lex∆assign 'nodeValue' ' '
node←node lex∆assign 'nodeType' 0
node←(⊂0⍴0),⊂node
∇
⍝ ********************************************************************
⍝
⍝ Node Methods
⍝
⍝ ********************************************************************
∇new←node dom∆node∆appendChild child;children
⍝⍝ Function to add a child to the end of our vector
new←node
children←(⊃node[1]),⊂child
new[1]←⊂children
∇
∇new←node dom∆node∆prependChild child; children
⍝⍝ Function to add a child tot he begining of our vector
new←node
children←(⊂child),1⊃node
new[1]←⊂children
∇
∇n←dom∆node∆nodeName node
n←(⊃node[2])lex∆lookup 'nodeName'
∇
∇new←node dom∆node∆setNodeName name
new←node[1],⊂(⊃node[2]) lex∆assign 'nodeName' name
∇
∇t←dom∆node∆nodeType node
t←(⊃node[2]) lex∆lookup 'nodeType'
∇
∇new←node dom∆node∆setNodeType type
new←node[1],⊂(⊃node[2]) lex∆assign 'nodeType' type
∇
∇v←dom∆node∆nodeValue node
v←(⊃node[2])lex∆lookup 'nodeValue'
∇
∇new←node dom∆node∆setNodeValue value
new←node[1],⊂(⊃node[2]) lex∆assign 'nodeValue' value
∇
∇o←dom∆node∆ownerDocument node
o←(⊃node[2]) lex∆lookup 'ownerDocument'
∇
∇new←node dom∆node∆setOwenerDocument doc
new←node[1],⊂(⊃node[2]) lex∆assign 'ownerDocument' doc
∇
∇ch←dom∆node∆children node
ch←⊃node[1]
∇
∇b←dom∆node∆hasChildren node
b←0≠1↑⍴1⊃node
∇
∇b←dom∆node∆hasAttributes node
b←~lex∆isempty dom∆node∆attributes node
∇
∇new←node dom∆node∆setChildren children
⍝⍝ Out with the old in with the new. This function replaces what
⍝⍝ ever children there are with an new list.
new←(⊂children),node[2]
∇
∇attrs←dom∆node∆attributes node
⍝⍝ Function returns a named node map of attributes
attrs←(⊃node[2]) lex∆lookup 'attributes'
∇
∇new←node dom∆node∆setAttribute item;attr;cix;attr_vector
→(dom∆attr∆predicate item)/setAttr
item←dom∆createAttribute item
setAttr:
attr←dom∆node∆attributes node
attr←attr dom∆namedNodeMap∆setNamedItem item
node[2]←⊂(2⊃node) lex∆assign 'attributes' attr
new←node
∇
∇xml←dom∆node∆toxml node;next;nextix
⍝⍝ Function returns an xml text vector for a node
→(elm,attr,txt,cdata,ref,ent,pi,com,doc,type,frag,note)[dom∆node∆nodeType
node]
elm: ⍝ Element
xml←'<',(dom∆node∆nodeName node)
⍎(dom∆node∆hasAttributes node)/'xml←xml,dom∆node∆toxml ¨
dom∆namedNodeMap∆list dom∆node∆attributes node'
⍎(~dom∆node∆hasChildren node)/'xml←xml,''/>''◊→0'
xml←xml,'>'
xml←xml,∊dom∆node∆toxml ¨ dom∆node∆children node
xml←xml,'</',(dom∆node∆nodeName node),'>'
→0
attr: ⍝ Attribute
→(dom∆TRUE utl∆stringEquals dom∆node∆nodeValue node)/single_attr
double_attr:
xml←' ',(dom∆node∆nodeName node),'="',(dom∆node∆nodeValue node),'"'
→0
single_attr:
xml←' ',dom∆node∆nodeName node
→0
txt: ⍝ Text
xml←dom∆node∆nodeValue node
→0
cdata: ⍝ CDATA
xml←dom∆node∆nodeValue node
→0
ref: ⍝ Entity Reference
xml←'NOT IMPLEMENTED'
→0
ent: ⍝ Entity
xml←'NOT IMPLEMENTED'
→0
pi: ⍝ Processing Instruction
xml←'<?',(dom∆pi∆target node),' ',(dom∆pi∆data node),'?>'
→0
com: ⍝ Comment Node
xml←'<!--',(dom∆node∆nodeValue node),'-->'
→0
doc: ⍝ Document node
xml← ∊dom∆node∆toxml ¨ dom∆node∆children node
→0
type: ⍝ Document Type node
xml←'<!DOCTYPE ',(dom∆node∆nodeName node)
→(~(2⊃node) lex∆haskey 'SYSTEM')/typePublic
xml←xml,' SYSTEM ',(2⊃node)lex∆lookup 'SYSTEM'
typePublic:
→(~(2⊃node) lex∆haskey 'PUBLIC')/typeEnd
xml←xml,' PUBLIC ',(2⊃node)lex∆lookup 'PUBLIC'
typeEnd:
xml←xml,'>'
→0
frag: ⍝ Document fragment
xml←'NOT IMPLEMENTED'
→0
note: ⍝ Notation
xml←'NOT IMPLEMENTED'
→0
∇
∇child←node dom∆node∆getChild n
⍝⍝ Returns the nth child of node
child←⊃(dom∆node∆children node)[n]
∇
∇children← dom∆node∆getChildren node
children←1⊃node
∇
∇b←dom∆node∆predicate node
⍝⍝ Function tests to see if node is a dom node. This is not conical,
⍝⍝ but I can't proceed without it.
→(~b←1=⍴⍴node)/0
→(~b←2=⍴node)/0
→(~b←lex∆is 2⊃node)/0
→(~b←(2⊃node) lex∆haskey 'nodeName')
→(~b←(2⊃node) lex∆haskey 'nodeValue')
→(~b←(2⊃node) lex∆haskey 'nodeType')
b←1
∇
⍝ ********************************************************************
⍝
⍝ Element Methods
⍝
⍝ ********************************************************************
∇new←dom∆element∆childless elm
⍝⍝ Method marks an element as childless ie <tag/>
new←elm
new[2]←⊂(2⊃new) lex∆assign 'childless' 1
∇
∇b←dom∆element∆isChildless elm
⍝⍝ Method returns the childless attribute
b←(2⊃elm) lex∆lookup 'childless'
∇
⍝ ********************************************************************
⍝
⍝ Document methods
⍝
⍝ ********************************************************************
∇node←dom∆document∆rootElement doc;children;i;lb
⍝⍝ Function returns the root element of a document
children←dom∆node∆children doc
i←1
lb←((⍴children)⍴st),ed
st:
node←⊃children[i]
→(dom∆ELEMENT_NODE=dom∆node∆nodeType node)/0
→lb[i←i+1]
ed:
node←dom∆createElement 'MALFORMED DOCUMENT'
→0
∇
∇doc←doc dom∆document∆setRootElement rootElm;children;i;lb
⍝⍝ Function replaces the root element of a document. Function should
⍝⍝ be called after updating or changing nodes of a document.
i←1
lb←((⍴children←⊃doc[1])⍴st),ed
st:
→(~dom∆ELEMENT_NODE=dom∆node∆nodeType ⊃children[i])/next
children[i]←⊂rootElm
next:
→lb[i←i+1]
ed:
doc[1]←⊂children
∇
∇type←dom∆document∆getDocumentType doc;children
⍝⍝ Function returns the document type node.
children←dom∆node∆getChildren doc
type←(dom∆DOCUMENT_TYPE_NODE = dom∆node∆nodeType¨children)/children
∇
∇doc←doc dom∆document∆setDocumentType typeNode;children;i;lb
⍝⍝ Function replaces the root element of a document. Function should
⍝⍝ be called after updating or changing nodes of a document.
i←1
lb←((⍴children←⊃doc[1])⍴st),ed
st:
→(~dom∆DOCUMENT_TYPE_NODE=dom∆node∆nodeType ⊃children[i])/next
children[i]←⊂typeNode
next:
→lb[i←i+1]
ed:
doc[1]←⊂children
∇
∇nl←name dom∆document∆getElementsByTagName node;children;child;lb
⍝⍝ Function returns a NodeList of elements with the give name
→(name utl∆stringEquals dom∆node∆nodeName node)/ahit
nl←⊂dom∆createNodeList
→ch
ahit:
nl←(⊂node),dom∆createNodeList
→ch
ch:
→(0=⍴children←dom∆node∆getChildren node)/0
child←1
lb←((⍴children)⍴st),end
st:
nl←nl,name dom∆document∆getElementsByTagName child⊃children
nl←(0≠∊⍴¨nl)/nl
→lb[child←child+1]
end:
∇
⍝ ********************************************************************
⍝
⍝ Attribute Methods
⍝
⍝ ********************************************************************
∇ b←dom∆attr∆predicate node
→(~b←dom∆node∆predicate node)/0
b←dom∆ATTRIBUTE_NODE = dom∆node∆nodeType node
∇
⍝ ********************************************************************
⍝
⍝ Nodelist Methods
⍝
⍝ ********************************************************************
∇nl←dom∆createNodeList
nl←0⍴0
∇
∇length←dom∆nodeList∆length list
length←''⍴⍴list
∇
∇node←list dom∆nodeList∆item item
⍝⍝ Returns the itemth
⍎(item>⍴list)/'item←0⍴0 ◊ →0'
node←item⊃list
∇
∇new←list dom∆nodeList∆appendNode node
⍝⍝ Function appends a node to a node list
→(0≠⍴list)/append
new←1⍴⊂node
→0
append:
new←list,⊂node
∇
∇ix←nodeList dom∆nodeList∆lookup name
⍝⍝ Function returns the index of the given node name in a node list.
ix←(dom∆node∆nodeName ¨ nodeList) utl∆listSearch name
∇
∇b←dom∆nodeList∆predicate list
⍝⍝ Function test whether list is a nodeList
→(~b←1=⍴⍴list)/0 ⍝ Not a list
b←∧/dom∆node∆predicate ¨ list
∇
⍝ ********************************************************************
⍝
⍝ NamedNodeMap
⍝
⍝ ********************************************************************
∇ map←dom∆createNamedNodeMap
map←lex∆init
∇
∇ node←map dom∆namedNodeMap∆getNamedItem name
node←map lex∆lookup name
∇
∇ map←old dom∆namedNodeMap∆setNamedItem attr;name
⍝⍝ Function to add or change an attribute
name←dom∆node∆nodeName attr
map←old lex∆assign name attr
∇
∇ map←old dom∆namedNodeMap∆removeNamedItem attr;name
⍝⍝ Function to remove an attribute
name←dom∆node∆nodeName attr
map←old lex∆drop name
∇
∇item←map dom∆namedNodeMap∆item index
⍝⍝ Function returns the indexth item in the map
item←2⊃map
∇
∇list←dom∆namedNodeMap∆list map
⍝⍝ Function returns the elements of the map as a list
list←lex∆values map
∇
⍝ ********************************************************************
⍝
⍝ Processing instructions are dom∆pi
⍝
⍝ ********************************************************************
∇target←dom∆pi∆target node
target←(⊃node[2]) lex∆lookup 'target'
∇
∇data←dom∆pi∆data node
data←(⊃node[2]) lex∆lookup 'data'
∇
⍝ ********************************************************************
⍝
⍝ Parse Methods
⍝
⍝ ********************************************************************
∇doc←dom∆parse txt;nl
⍝⍝ Function to parse an xml text buffer
nl←dom∆parse∆nodeFromSource ¨ '>' dom∆split txt
doc←dom∆parse∆foldNodeList nl
∇
∇node←dom∆parse∆nodeFromSource src;b
⍝⍝ dom∆parse subroutine returns a node list from the source once it
⍝⍝ has been split on '>'
→(0=⍴src)/txtNode
src←utl∆clean src
b←(∧/'<!-'=3↑src),(∧/'<!D'=3↑src),(∧/'</'=2↑src),(∧/'<?'=2↑src),('<'=1↑src),1
→b/(commentNode,doctypeNode,closeElm,proc,openElm,txtNode)
commentNode:
node←dom∆parse∆commentNode src
→end
doctypeNode:
node←dom∆parse∆doctypeNode src
→end
proc:
node←dom∆parse∆processingInstruction src
→end
openElm:
node←dom∆parse∆openElm src
→end
closeElm:
node←dom∆parse∆closeElm src
→end
txtNode:
node←dom∆createTextNode src
end:
∇
∇node←dom∆parse∆commentNode source
⍝⍝ Function creates a comment node from the source.
node←dom∆createComment 3↓source
∇
∇node←dom∆parse∆doctypeNode source
⍝⍝ Function creates a doctype node from source
node←dom∆createDocumentType 10↓source ⍝ 8 == ⍴ '<!DOCTYPE '
∇
∇node←dom∆parse∆processingInstruction source
⍝⍝ Function creates a processing instruction
node←dom∆createProcessingInstruction 2↓¯1↓source
∇
∇elm←dom∆parse∆openElm source;b;name;closed;attr;ix
⍝⍝ Function returns an element node from source.
name←1↓(b←∧\source≠' ')/source
name←(closed←'/'=¯1↑name)↓name
elm←dom∆createElement name
⍎closed/'elm←dom∆element∆childless elm'
→(∧/b)/ed
attr←'=' utl∆split_with_quotes ¨ ' ' utl∆split_with_quotes 1↓(~b)/source
ix←1
st:
→(ix>⍴attr)/ed
elm←elm dom∆node∆setAttribute ix⊃attr
ix←ix+1
→st
ed:
∇
∇node←dom∆parse∆closeElm source
⍝⍝ Function returns a place holder from the end of an element.
node←dom∆createElement 1↓source
node←node dom∆node∆setNodeValue 'Closing element'
node←node dom∆node∆setNodeType dom∆special_ELEMENT_END
∇
∇doc←dom∆parse∆foldNodeList nl;curNode;nlix;nodeStack;b;docNode
⍝⍝ Function traverses node list nl finding children and assigning
⍝⍝ them to their parent.
doc←dom∆createDocument '#Document'
nodeStack← st∆init
nlix←1
⍝ First loop to find the root element
st1:
curNode←nlix⊃nl
⍎(dom∆DOCUMENT_TYPE_NODE=dom∆node∆nodeType curNode)/'doc←doc
dom∆node∆appendChild curNode ◊ →nxt1'
⍎('xml' utl∆stringEquals dom∆node∆nodeName curNode)/'doc←doc
dom∆node∆appendChild curNode ◊ →nxt1'
→(dom∆ELEMENT_NODE ≠ dom∆node∆nodeType curNode)/nxt1
nodeStack←nodeStack st∆push doc
nodeStack←nodeStack st∆push curNode
nxt1:
nlix←nlix+1
→(2=st∆length nodeStack)/st2
→st1
⍝ Second loop to find the children of the root element
st2:
curNode←nlix⊃nl
→(dom∆ELEMENT_NODE dom∆special_ELEMENT_END dom∆TEXT_NODE = dom∆node∆nodeType
curNode)/elm,elmEnd,txt
⍝ What do I do now?
→nxt2
elm:
nodeStack←nodeStack dom∆parse∆foldElement curNode
→nxt2
elmEnd:
nodeStack←nodeStack dom∆parse∆endElement curNode
→nxt2
txt:
nodeStack←nodeStack dom∆parse∆foldText curNode
→nxt2
nxt2:
nlix←nlix+1
→(nlix>⍴nl)/ed
→st2
ed:
doc←nodeStack st∆nth st∆length nodeStack
st3:
→(1=st∆length nodeStack)/0
curNode←st∆peek nodeStack
nodeStack←st∆pop nodeStack
doc←doc dom∆node∆appendChild curNode
→st3
∇
∇ newStack←nodeStack dom∆parse∆foldText txt;words;tag;parent
⍝⍝ Function folds a text node into the nodeStack
words←dom∆node∆nodeValue txt
words←'<' utl∆split utl∆clean words
→('/'=1↑tag←,⊃¯1↑words)/endFound
newStack←nodeStack st∆push txt
→0
endFound:
tag←1↓tag ⍝ For '/'
txt←txt dom∆node∆setNodeValue utl∆clean 1⊃words
parent←st∆peek nodeStack
⍎(~tag utl∆stringEquals dom∆node∆nodeName parent)/'newStack←nodeStack st∆push
txt ◊ →0'
nodeStack←st∆pop nodeStack
parent←parent dom∆node∆appendChild txt
newStack←nodeStack st∆push parent
→0
∇
∇ newStack←nodeStack dom∆parse∆foldElement elm;parent
⍝⍝ Function folds an element node into the nodelist
newStack←nodeStack st∆push curNode
∇
∇ nodeStack←nodeStack dom∆parse∆endElement curNode;ix;iy;child;name
⍝⍝ Routine to append children on stack to the current element node.
name←('/'=name[1])↓name←dom∆node∆nodeName curNode
→(dom∆element∆isChildless curNode)/0
ix←1
st1:
→(name utl∆stringEquals dom∆node∆nodeName nodeStack st∆nth ix)/nxt
ix←ix+1
→st1
nxt:
→(ix=1)/ed
child←st∆peek nodeStack
nodeStack←st∆pop nodeStack
ix←ix - 1
nodeStack[ix]←⊂(ix⊃nodeStack) dom∆node∆prependChild child
→nxt
ed:
∇
⍝ ********************************************************************
⍝
⍝ Meta
⍝
⍝ ********************************************************************
∇Z←dom⍙metadata
Z←0 2⍴⍬
Z←Z⍪'Author' 'Bill Daly'
Z←Z⍪'BugEmail' '[email protected]'
Z←Z⍪'Documentation' 'doc/apl-library.info'
Z←Z⍪'Download'
'https://sourceforge.net/projects/apl-library/files/latest/download?source=directory'
Z←Z⍪'License' 'GPL'
Z←Z⍪'Portability' 'L2'
Z←Z⍪'Provides' 'dom'
Z←Z⍪'Requires' 'util lex'
Z←Z⍪'Version' '0 2 5'
Z←Z⍪'Last update' '2019-07-01'
∇
dom∆ELEMENT_NODE←1
dom∆ATTRIBUTE_NODE←2
dom∆TEXT_NODE←3
dom∆CDATA_SECTION_NODE←4
dom∆ENTITY_REFERENCE_NODE←5
dom∆ENTITY_NODE←6
dom∆PROCESSING_INSTRUCTION_NODE←7
dom∆COMMENT_NODE←8
dom∆DOCUMENT_NODE←9
dom∆DOCUMENT_TYPE_NODE←10
dom∆DOCUMENT_FRAGMENT_NODE←11
dom∆NOTATION_NODE←12
dom∆special_ELEMENT_END←50
dom∆type∆DESC←12⍴0
dom∆type∆DESC[1]←⊂'Element'
dom∆type∆DESC[2]←⊂'Attribute'
dom∆type∆DESC[3]←⊂'Text'
dom∆type∆DESC[4]←⊂'CDATA section'
dom∆type∆DESC[5]←⊂'Entity reference'
dom∆type∆DESC[6]←⊂'Entity'
dom∆type∆DESC[7]←⊂'Processing instruction'
dom∆type∆DESC[8]←⊂'Comment'
dom∆type∆DESC[9]←⊂'Document'
dom∆type∆DESC[10]←⊂'Document type'
dom∆type∆DESC[11]←⊂'Document fragment'
dom∆type∆DESC[12]←⊂'Notation'
dom∆TRUE←'True'
dom∆FALSE←'False'
dom∆defaultImplementation←'THIS WORKSPACE'
dom∆error∆NOT_FOUND←'NOT FOUND'
∇v←delim dom∆split string;b
⍝ Split a string at delim. No recursive algorithm for dom parsing.
b←(delim=string)/⍳⍴string←,string
b←b,[1.1]-b-¯1+1↓b,1+⍴string
v←dom∆sph ¨ ⊂[2]b
∇
∇item←dom∆sph ix
⍝ Helper function for dom∆split returns an item from a character
⍝ vector where ix index of the delimeter in the stringstring and the
⍝ length of the item.
ix←ix[1]+⍳ix[2]
item←string[ix]
∇
#!/usr/local/bin/apl --script
⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝
⍝
⍝ lex 2016-08-29 15:55:56 (GMT-5)
⍝
⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝
⍝ Copyright (C) 2016 Bill Daly
⍝ This program is free software: you can redistribute it and/or modify
⍝ it under the terms of the GNU 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 General Public License for more details.
⍝ You should have received a copy of the GNU General Public License
⍝ along with this program. If not, see <http://www.gnu.org/licenses/>.
∇nx←lx lex∆assign item;ix;keys;keyShape
⍝⍝ Function to assign a value to a key where larg is the lexicon and
⍝⍝ rarg is a key value pair. Pair will be added if the key is not in
⍝⍝ the lexicon.
nx←lx
→(' '≠1↑0⍴⊃item[1])/err
⍝ Test for empty lexicon
→(0=1↑⍴nx)/add
keyShape←⍴keys←⊃nx[;1]
ix←(keys∧.=keyShape[2]↑⊃item[1])/⍳keyShape[1]
→(0=⍴ix)/add
replace:
nx[ix;2]←item[2]
→0
add:
nx←nx,[1]item
→0
err:
⍞←'Lexicon entries must use a character string as a key'
→0
∇
∇new←lex lex∆drop key;rlex;tbl
⍝⍝ Function to drop a key value pair
⍎(0=1↑⍴lex)/'new←lex◊→0'
rlex←(⍴tbl←⊃lex[;1])⌈0,⍴key←,key
new←(~(rlex↑tbl)∧.=rlex[2]↑key)⌿lex
∇
∇bool←lex lex∆haskey key;rkey;keys
⍝⍝ Function searches for key in lexicon lex and returns true if found.
⍎(0=1↑rkey←⍴keys←⊃lex[;1])/'bool←0◊→0'
rkey[2]←rkey[2]⌈⍴key←,key
bool←∨/(rkey↑keys)∧.=rkey[2]↑,key
∇
∇lex←lex∆init
⍝⍝ Function to initiate a lexicon
lex←0 2⍴''
∇
∇b←lex∆is lex
⍝⍝ Predicate returns true if argument is in fact a lexicon
⍎(2≠⍴⍴lex)/'b←0◊→0'
⍎(∧/0 2=⍴lex)/'b←1◊→0'
⍎(2>≡lex)/'b←0◊→0'
b←∧/' '=1↑0⍴⊃lex[;1]
∇
∇b←lex∆isempty lex
⍝⍝ Predicate returns true is the lexicon has no entries
b←∧/0 2=⍴lex
∇
∇keys←lex∆keys lx
⍝⍝ Function returns a list of keys in a lexicon
keys←lx[;1]
∇
∇value←lex lex∆lookup key;keyShape;keys;ix
⍝⍝ Function returns the value of key in a lexicon
keyShape←¯2↑0 0,⍴keys←⊃lex[;1]
⍎(0=ix←''⍴(keys∧.=keyShape[2]↑key)/⍳keyShape[1])/'value←''''◊→0'
value←⊃lex[ix;2]
∇
∇vals←lex∆values lx
⍝⍝ returns the valus in a lexicon
vals←lx[;2]
∇
∇new←lex lex∆from_alist list
⍝⍝ Function to generate a lexicon from a list
⎕es (0≠2|⍴list←,list)/'List must consist of name-value pairs.'
→(2=⎕nc 'lex')/recursion
lex←lex∆init
recursion:
new←lex
→(0=⍴list←,list)/0
new← (new lex∆assign 2↑list←,list) lex∆from_alist 2↓list
∇
∇Z←lex⍙metadata
Z←0 2⍴⍬
Z←Z⍪'Author' 'Bill Daly'
Z←Z⍪'BugEmail' '[email protected]'
Z←Z⍪'Documentation' 'eoc/apl-library.info'
Z←Z⍪'Download'
'https://sourceforge.net/p/apl-library/code/ci/master/tree/lex.apl'
Z←Z⍪'License' 'GPL v3.0'
Z←Z⍪'Portability' 'L1'
Z←Z⍪'Provides' ''
Z←Z⍪'Requires' ''
Z←Z⍪'Version' '0 1 2'
Z←Z⍪'Last update' '2019-07-01'
∇
#! /usr/local/bin/apl --script
⍝ ********************************************************************
⍝ $Id: $
⍝ $desc: Library of useful apl functions $
⍝ ********************************************************************
⍝ Util
⍝ Copyright (C) 2016 Bill Daly
⍝ This program is free software: you can redistribute it and/or modify
⍝ it under the terms of the GNU 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 General Public License for more details.
⍝ You should have received a copy of the GNU General Public License
⍝ along with this program. If not, see <http://www.gnu.org/licenses/>.
∇msg←utl∆helpFns fn;src;t
⍝⍝ Display help about a function
src←⎕cr fn
t←(+/∧\src=' ')⌽src
msg←(1,∧\'⍝'=1↓t[;1])⌿src
∇
∇msg←utl∆functionList prefix;list
⍝⍝ Display help for a list of functions whose name begins with
⍝⍝ prefix.
list←utl∆clean¨⊂[2](list[;⍳⍴prefix]∧.=prefix)⌿list←⎕nl 3
msg←{⎕tc,⎕tc,'∇',⎕tc[3] utl∆join ⊂[2]utl∆helpFns ⍵}¨list
∇
∇t←utl∆numberp v
⍝⍝ Is arg a number?
→(0=⍴t←''⍴0=⍴v)/0
⍎(1<≡v)/'t←0◊→0'
t←''⍴0=1↑0⍴v
∇
∇ t←utl∆stringp s
⍝⍝ Is arg a string?
⍝⍝ test for nested array
→(~t←1=≡s)/0
t←''⍴' '=1↑0⍴s←,s
∇
∇b←utl∆numberis tst
⍝⍝ Test whether a number can be obtained by executing a string
⍎(0=⍴tst←,tst)/'b←0 ◊ →0'
⍝⍝ Rotate spaces to right side
tst←(+/∧\tst=' ')⌽tst
⍝⍝ Test for spaces imbedded in numbers
→(~b←(+/∧\b)=+/b←tst≠' ')/0
b←(∧/tst∊' 1234567890-¯.')∧∨/0 1=+/tst='.'
b←b∧∧/~(1↓tst)∊'-¯'
∇
∇New←utl∆stripArraySpaces old;b
⍝⍝ Strips off leading and trailing spaces. Function operates on both
⍝⍝ vectors and arrays of rank 2. See also utl∆clean.
New←(+/∧\old=' ')⌽old
b←⌊/+/∧\⌽New=' '
→(V,M,E)[3⌊⍴⍴old]
⍝ Vector
V:
New←New[⍳-b-⍴New]
→0
⍝ Matrix
M:
New←New[;⍳-b-1↓⍴New]
→0
⍝ Error -- rank of old is too high
E:
⎕es 'Rank of array is too high'
∇
∇cl←utl∆clean txt;b;ix
⍝⍝ Converts all whites space to spaces and then removes duplicate
⍝⍝ spaces. See also utl∆stringArraySpaces.
txt←,txt
ix←(txt∊⎕tc,⎕av[10])/⍳⍴txt
txt[ix]←' '
→(0=⍴cl←(~(1⌽b)∧b←txt=' ')/txt)/0
cl←(cl[1]=' ')↓(-cl[⍴cl]=' ')↓cl
∇
∇o←k utl∆sub d
⍝⍝ Calculates subtotals for each break point in larg
o←+\[1]d
⍝ Test for rank of data
⎕es (~(⍴⍴d) ∊ 1 2)/'RANK ERROR'
→(V,A)[⍴⍴d]
⍝ Vectors
V:o←o[k]-¯1↓0,o[k]
→0
⍝ Arrays (of rank 2)
A: o←o[k;]-0,[1] o[¯1↓k;]
→0
∇
∇string←delim utl∆join vector
⍝⍝ Returns a character string with delim delimiting the items
⍝⍝ in vector.
string←1↓∊,delim,(⌽1,⍴vector)⍴vector
∇
∇v←delim utl∆split string;b;c
⍝⍝ Splits a character string into a nested vector of strings using
⍝⍝ delim as the delimiter.
→(1≠⍴delim←,delim)/many
→(∧/b←string ≠ delim)/last
→exit
many:
→(∧/~b←string∊delim)/last
string←(c←~b∧1⌽b)/string
b←c/~b
→exit
exit:
v←(⊂b/string),delim utl∆split 1↓(~b←∧\b)/string
→0
last:
v←1⍴⊂string
∇
∇v←delim utl∆split2 string;b
⍝⍝ Split a string at delim. No recursive algorithm
b←(delim=string)/⍳⍴string←,string
b←b,[1.1]-b-¯1+1↓b,1+⍴string
v←utl∆sph ¨ ⊂[2]b
∇
∇item←utl∆sph ix
⍝⍝ Helper function for utl∆split returns an item from a character
⍝⍝ vector where ix index of the delimeter in the stringstring and the
⍝⍝ length of the item.
ix←ix[1]+⍳ix[2]
item←string[ix]
∇
∇ix← list utl∆listSearch item;rl;ri;l
⍝⍝ Search a character list for an item.
→(1=≡list)/arr
list←⊃list
arr:
⎕es(2≠⍴rl←⍴list)/'RANK ERROR'
ri←⍴item←,item
l←rl[2]⌈ri
→(0=⍴ix←(((rl[1],l)↑list)∧.=l↑,item)⌿⍳rl[1])/naught
ix←''⍴ix
→0
naught:
ix←1+''⍴⍴list
∇
∇ix←txt utl∆search word;⎕io;old∆io;ixx;bv
⍝⍝ Search for larg in rarg.
old∆io←⎕io
⎕io←0
ixx←⍳⍴txt←,txt
bv←(txt=1↑word←,word)∧ixx≤(⍴txt)-⍴word
ix←bv/ixx
ix←old∆io+(txt[ix∘.+⍳⍴word]∧.=word)/ix
∇
∇new←txt utl∆replace args;ix
⍝⍝ Search for and replace an item in rarg. Larg is a two element
⍝⍝ vector where Larg[1] is the text to search for, Larg[2] is the
⍝⍝ replacement text.
ix← txt utl∆search ⊃args[1]
new←((¯1+ix)↑txt),(,⊃args[2]),(¯1+(ix←''⍴ix)+⍴,⊃args[1])↓txt
∇
∇t←n utl∆execTime c;ts;lb;i
⍝⍝ Returns the number of milliseconds a command took. larg is the
⍝⍝ number of times to execute command. If larg is missing we execute
⍝⍝ once.
→(2=⎕nc 'n')/many
ts←⎕ts
⍎c
→ed
many:
lb←(n⍴st),ed
i←0
ts←⎕ts
st:
⍎c
→lb[i←i+1]
ed:
t←⎕ts
t←(60 1000⊥t[6 7])-60 1000⊥ts[6 7]
→0
∇
∇today←utl∆today
⍝⍝ Today's date as a string
today←'06/06/0000'⍕⎕ts[2 3 1]
∇
∇txt←utl∆lower m;ix
⍝⍝ Convert text to all lower case.
m←⎕ucs m←,m
ix←((m≥65)∧m≤90)/⍳⍴m
m[ix]←m[ix]+32
txt←⎕ucs m
∇
∇txt←utl∆upper m;ix
⍝⍝ Convert text to all upper case.
m←⎕ucs m←,m
ix←((m≥97)∧m≤122)/⍳⍴m
m[ix]←m[ix]-32
txt←⎕ucs m
∇
∇v←delim utl∆split_with_quotes string;b;c
⍝⍝ Split a string on a delimiter where some delimiter(s) may be
⍝⍝ inside quotes and therefore ignored.
delim←,delim
b←~(string∊delim)∧~≠\string='"'
v←(⊂c/string), ((~c)/b) utl∆swq_helper (~c←∧\b)/string
v←utl∆strip_quotes ¨ v
∇
∇v←b utl∆swq_helper string;c;d
⍝⍝ Helper function for utl∆split_with_quotes
→(0=+/~b)/end
d←~c←∧\1↓b
v←(⊂c/1↓string), (d/1↓b) utl∆swq_helper d/1↓string
→0
end:
v←0⍴0
∇
∇b←str1 utl∆stringEquals str2;l
⍝⍝ Compare two strings.
l←(⍴str1)⌈⍴str2
b←∧/(l↑str1)=l↑str2
∇
∇txt←utl∆crWithLineNo name;l
⍝⍝ Add line numbers to a character representation of a function.
l←¯1+1↑⍴txt←⎕cr name
txt←(' ∇',[1]'[000] '⍕⍪⍳l),txt
∇
∇clean←utl∆strip_quotes txt;bv
⍝⍝ Strip quotes from the start and end of character string.
clean←txt
→(~1↑bv←≠\clean∊'''"')/0
clean←(bv∧¯1⌽bv)/clean
∇
∇new←om utl∆round old
⍝⍝ Round numbers based on the Order of Magnitude. Left
⍝⍝ arg is thus a power of ten where positive numbers round to the
⍝⍝ left of the decimal point and negative to the right.
⍎(2≠⎕nc'om')/'om←0'
om←10*om
new←om×⌊.5+old÷om
∇
∇ar←utl∆concatColumns na
⍝⍝ Function returns a 2 dimensional text array from a nested array of text.
→(1=¯1↑⍴na)/lastCol
ar←(⊃na[;1]),' ', utl∆concatColumns 0 1↓na
→0
lastCol:
ar←⊃,na
→0
∇
∇n←utl∆convertStringToNumber s;bv;a
⍝⍝ Converts a vector of characters to a number. Function
⍝⍝ returns the original string when it fails in this attempt. For
⍝⍝ strings multiple numbers see utl∆import∆numbers.
→(~∧/s∊'0123456789.,+-¯ ()')/fail
→(1<+/s='.')/fail
→(0=⍴(s≠' ')/s)/fail
a←((~∧\bv)∧⌽~∧\⌽bv←s=' ')/s
→(0≠+/a=' ')/fail
→((∨/a='+')∧a[1]≠'+')/fail
→(∧/'-'=(' '≠a)/a)/zero
a[(a∊'(-')/⍳⍴a←,' ',a]←'¯'
n←⍎(~a∊'),')/a
→0
zero: ⍝ Excel sometimes uses dash for 0
n←0
→0
fail:
n←s
∇
∇n←utl∆import∆numbers s;bv
⍝⍝ Function to turn a column of figures (ie characters) into
⍝⍝ numbers. For a single number see util∆convertStringToNumber
⍎(2=≡s)/'s←⊃s'
bv←~∧/s=' '
s[(s∊'(-')/⍳⍴s←,' ',s]←'¯'
n←bv\⍎(~s∊'),')/s
∇
∇utl∆es msg
⍝⍝ Simulate an error. Similar to ⎕es with better control of the error
⍝⍝ message. Thanks JAS
→(0=⍴msg)/0
msg ⎕es 0 1
∇
∇b←list utl∆member item
⍝⍝ Tests whether a character vector is in list, a character array,
⍝⍝ or a nested list of strings.
b←(1+1↑⍴list)>list utl∆stringSearch item
∇
∇parsed←utl∆fileName∆parse fname;suffix
⍝⍝ Function breaks a fname down into three strings:
⍝⍝ 1) Path to directory
⍝⍝ 2) root name
⍝⍝ 3) suffix, that is whatever trails the final '.'.
parsed←'/' utl∆split fname
suffix←'.' utl∆split (⍴parsed)⊃parsed
→(one,many)[2⌊⍴suffix]
one:
parsed←(⊂'/' utl∆join ¯1↓ parsed),⊃suffix,⊂''
→0
many:
parsed←(⊂'/' utl∆join ¯1↓ parsed),(⊂'.'utl∆join ¯1↓suffix),¯1↑suffix
→0
∇
∇dir←utl∆fileName∆dirname parsed
⍝⍝ Function returns the directory portion of a parsed file name
dir←1⊃parsed
∇
∇base←utl∆fileName∆basename parsed
⍝⍝ Function returns the base of the file name from a parsed file name
base←2⊃parsed
∇
∇suffix←utl∆fileName∆suffixname parsed
⍝⍝ Function returns the suffix of a parsed file name.
suffix ← 3⊃parsed
∇
∇backup←utl∆fileName∆backupname parsed
⍝⍝ Function returns a name to which a file can be backed up.
backup←(1⊃parsed),'/',(2⊃parsed),'.bak'
∇
∇ar←utl∆concatColumns na
⍝⍝ Function returns a 2 dimensional text array from a nested array of text
→(1=¯1↑⍴na)/lastCol
ar←(⊃na[;1]),' ', utl∆concatColumns 0 1↓na
→0
lastCol:
ar←⊃,na
→0
∇
∇sub←breakFld utl∆breakon amts;ix
⍝⍝ function to calculate subtotals for changes in breakFld
ix←(~breakFld utl∆stringEquals ¨ 1⌽breakFld)/⍳⍴breakFld←,breakFld
sub←ix utl∆sub amts
∇
∇b←str utl∆stringMember list
⍝⍝ Function returns true if str is in list
b←∨/(⊂str) utl∆stringEquals ¨ list
∇
∇numbered←utl∆numberedArray array;shape;level
⍝⍝ Function prepends a line number on to an array
shape←⍴array
utl∆es ((0=level)∨(2≠⍴⍴array)∨2<level←≡array)/'Malformed array for these
purposes'
numbered←('[003] '⍕(shape[1],1)⍴⍳shape[1]),array
∇
∇ix←utl∆gradeup data;t1;base
⍝⍝ Function to alphabetically grade up data
⍎(∧/(2=≡data),t1←utl∆stringp ¨ data)/'data←⊃data'
utl∆es (~∧/t1)/'DATA NOT CHARACTERS'
base←2*⍳20
base←base[+/1,∧\base<⌈/⎕ucs ∊,data]
ix←⍋(⊂(¯1↑⍴data)⍴base)⊥¨⊂[2]⎕ucs¨data
∇
∇new ← utl∆sort old;base
⍝⍝ Function sorts a character array or nested character vectors
new←old[utl∆gradeup old]
∇
∇ix←data utl∆quad bottom_right;top_left;rows;cols;all
⍝⍝ Function returns the row and column indices defined by the top
⍝⍝ right and bottom left indices in the right argument
→(2≠⎕nc 'data')/syntax
→(1≠⍴⍴bottom_right)/syntax
⍝ →(2=⍴bottom_right)/nested
→(4≠⍴bottom_right)/syntax
top_left←bottom_right[1 2]
bottom_right←bottom_right[3 4]
→step2
nested:
top_left←1⊃bottom_right
bottom_right←2⊃bottom_right
→step2
step2:
→(~utl∆numberp top_left,bottom_right)/syntax
rows←((top_left[1]≤all)∧bottom_right[1]≥all)/all←⍳1↑⍴data
cols←((top_left[2]≤all)∧bottom_right[2]≥all)/all←⍳1↓⍴data
ix←(⊂rows),⊂cols
→0
syntax:
utl∆es 'SYNTAX IS: data_array utl∆quad upper_left, bottom_right'
∇
∇rs←delim utl∆bifurcate txt;bv
⍝⍝ Function breaks a string into two parts using delim.
bv←∧\txt≠⍬⍴delim
⍎((+/bv)=⍴txt)/'rs←txt ◊ →0'
rs←(⊂bv/txt),⊂(+/1,bv)↓txt
∇
∇wrpd←width utl∆wrap txt;curln;spaces;cut
⍝⍝ Function returns a multi-line text no wider the width
→(width≥⍴txt)/last
spaces←(txt=' ')/⍳⍴txt
cut←⌈/(spaces≤width)/spaces
wrpd←(⊂(cut-1)↑txt), width utl∆wrap cut↓txt
→0
last:
wrpd←⊂txt
∇
∇Z←utl⍙metadata
Z←0 2⍴⍬
Z←Z⍪'Author' 'Bill Daly'
Z←Z⍪'BugEmail' '[email protected]'
Z←Z⍪'Documentation' 'doc/apl-library.info'
Z←Z⍪'Download'
'https://sourceforge.net/p/apl-library/code/ci/master/tree/utl.apl'
Z←Z⍪'License' 'GPL v3.0'
Z←Z⍪'Portability' 'L1'
Z←Z⍪'Provides' ''
Z←Z⍪'Requires' ''
Z←Z⍪'Version' '0 1 4'
Z←Z⍪'Last update' '2019-07-01'
∇
#! /usr/local/bin/apl --script
⍝ ********************************************************************
⍝ stack.apl implement a stack in apl; You're just lucky I didn't name
⍝ them cons, car and cdr.
⍝ Copyright (C) 2019 Bill Daly
⍝ This program is free software: you can redistribute it and/or modify
⍝ it under the terms of the GNU 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 General Public License for more details.
⍝ You should have received a copy of the GNU General Public License
⍝ along with this program. If not, see <http://www.gnu.org/licenses/>.
⍝ ********************************************************************
∇stack←st∆init
⍝ Function sets up the stack
stack←⍬
∇
∇stack←old st∆push item
stack←(⊂item),old
∇
∇item←st∆peek stack
item←1⊃stack
∇
∇stack←old st∆poke item
⍝ Function to replace the top of the stack
stack←old
stack[1]←⊂item
∇
∇stack←st∆pop old
⍎(0=⍴old)/'stack←old◊→0'
stack←1↓old
∇
∇len←st∆length stack
len←⍴stack
∇
∇item←stack st∆nth ix;l
⍝ Function returns the nth item on the stack
utl∆es (ix > l←st∆length stack)/'PEEKING PAST END OF STACK'
item ←ix⊃stack
∇
∇Z←st⍙metadata
Z←0 2⍴⍬
Z←Z⍪'Author' 'Bill Daly'
Z←Z⍪'BugEmail' '[email protected]'
Z←Z⍪'Documentation' 'doc/apl-library.info'
Z←Z⍪'Download' 'sourceforge.net/projects/apl-library/'
Z←Z⍪'License' 'GPL v3'
Z←Z⍪'Portability' 'L1'
Z←Z⍪'Provides' 'st'
Z←Z⍪'Requires' ''
Z←Z⍪'Version' '0 0 1'
∇
