mmarco/kenzo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge remote-tracking branch 'refs/remotes/origin/team-review'

Browse Source
This commit is contained in:
gheber 2015-11-30 09:31:59 -06:00
commit 19998214e8
18 changed files with 3200 additions and 2771 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

606
examples/Chapter1.ipynb
View File

File diff suppressed because it is too large Load Diff

32
examples/Chapter2.ipynb
View File

@ -15,7 +15,7 @@
" Load 1 ASDF system:\n", " Load 1 ASDF system:\n",
" kenzo\n", " kenzo\n",
"; Loading \"kenzo\"\n", "; Loading \"kenzo\"\n",
"\n" "..\n"
] ]
}, },
{ {
@ -102,21 +102,22 @@
"2. BCC, an object of type CHAIN-COMPLEX, the bottom chain complex C. Its reader\n", "2. BCC, an object of type CHAIN-COMPLEX, the bottom chain complex C. Its reader\n",
" function is BCC1.\n", " function is BCC1.\n",
"\n", "\n",
"3. F, an object of type MORPHISM representing the morphism f. Its reader\n", "3. F, an object of type MORPHISM representing the chain morphism f. Its reader\n",
" function is F1.\n", " function is F1.\n",
"\n", "\n",
"4. G, an object of type MORPHISM representing the morphism g. Its reader\n", "4. G, an object of type MORPHISM representing the chain morphism g. Its reader\n",
" function is G1.\n", " function is G1.\n",
"\n", "\n",
"5. H, an object of type MORPHISM representing the morphism h. Its reader\n", "5. H, an object of type MORPHISM representing the morphism of graded modules h.\n",
" function is H1.\n", " Its reader function is H1.\n",
"\n", "\n",
"9. IDNM, an integer, a system-generated identifier for this object. Its reader\n", "9. IDNM, an integer, a system-generated identifier for this object. Its reader\n",
" function is IDNM.\n", " function is IDNM.\n",
"\n", "\n",
"10. ORGN, a list containg a comment indicating the origin of the object. The\n", "10. ORGN, a list containg a comment indicating the origin of the object.\n",
" should be unique (per session), since it is used in the implementation for\n", " This comment should be unique for a Kenzo session (between calls of\n",
" caching purposes. Its reader function is ORGN.\n", " CAT-INIT), as it is used for caching purposes. Its reader function\n",
" is ORGN.\n",
"-----------------------------------------------------------------------------\"" "-----------------------------------------------------------------------------\""
] ]
}, },
@ -152,11 +153,14 @@
"Returns an instance of the class REDUCTION. The keyword arguments are as\n", "Returns an instance of the class REDUCTION. The keyword arguments are as\n",
"follows:\n", "follows:\n",
"\n", "\n",
":F F, an object of type morphism representing the morphism f of a reduction\n", ":F F, an object of type MORPHISM representing the chain morphism f of a\n",
" reduction\n",
"\n", "\n",
":G G, an object of type morphism representing the morphism g of a reduction\n", ":G G, an object of type MORPHISM representing the chain morphism g of a\n",
" reduction\n",
"\n", "\n",
":H H, an object of type morphism representing the morphism h of a reduction\n", ":H H, an object of type MORPHISM representing the morphism of graded modules h\n",
" of a reduction\n",
"\n", "\n",
":ORGN ORGN, a list containing a relevant and carefully chosen comment about\n", ":ORGN ORGN, a list containing a relevant and carefully chosen comment about\n",
" the origin of the chain complex. This comment should be unique\n", " the origin of the chain complex. This comment should be unique\n",
@ -1214,7 +1218,7 @@
"cell_type": "markdown", "cell_type": "markdown",
"metadata": {}, "metadata": {},
"source": [ "source": [
"## 2.6 Construction of abicone from 2 reductions\n", "## 2.6 Construction of a bicone from 2 reductions\n",
"#### Example" "#### Example"
] ]
}, },
@ -2173,7 +2177,7 @@
}, },
{ {
"cell_type": "code", "cell_type": "code",
"execution_count": 64, "execution_count": 65,
"metadata": { "metadata": {
"collapsed": false "collapsed": false
}, },
@ -2253,7 +2257,7 @@
"NIL" "NIL"
] ]
}, },
"execution_count": 64, "execution_count": 65,
"metadata": {}, "metadata": {},
"output_type": "execute_result" "output_type": "execute_result"
} }

247
examples/diabolo.graphml Normal file
View File

@ -0,0 +1,247 @@
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<graphml xmlns="http://graphml.graphdrawing.org/xmlns" xmlns:java="http://www.yworks.com/xml/yfiles-common/1.0/java" xmlns:sys="http://www.yworks.com/xml/yfiles-common/markup/primitives/2.0" xmlns:x="http://www.yworks.com/xml/yfiles-common/markup/2.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:y="http://www.yworks.com/xml/graphml" xmlns:yed="http://www.yworks.com/xml/yed/3" xsi:schemaLocation="http://graphml.graphdrawing.org/xmlns http://www.yworks.com/xml/schema/graphml/1.1/ygraphml.xsd">
<!--Created by yEd 3.14.4-->
<key attr.name="Description" attr.type="string" for="graph" id="d0"/>
<key for="port" id="d1" yfiles.type="portgraphics"/>
<key for="port" id="d2" yfiles.type="portgeometry"/>
<key for="port" id="d3" yfiles.type="portuserdata"/>
<key attr.name="url" attr.type="string" for="node" id="d4"/>
<key attr.name="description" attr.type="string" for="node" id="d5"/>
<key for="node" id="d6" yfiles.type="nodegraphics"/>
<key for="graphml" id="d7" yfiles.type="resources"/>
<key attr.name="url" attr.type="string" for="edge" id="d8"/>
<key attr.name="description" attr.type="string" for="edge" id="d9"/>
<key for="edge" id="d10" yfiles.type="edgegraphics"/>
<graph edgedefault="directed" id="G">
<data key="d0"/>
<node id="n0">
<data key="d6">
<y:ShapeNode>
<y:Geometry height="160.0" width="110.0" x="64.86431999999999" y="336.0"/>
<y:Fill color="#FFFFFF" transparent="false"/>
<y:BorderStyle hasColor="false" type="line" width="1.0"/>
<y:NodeLabel alignment="center" autoSizePolicy="content" fontFamily="Dialog" fontSize="12" fontStyle="plain" hasBackgroundColor="false" hasLineColor="false" hasText="false" height="4.0" modelName="custom" textColor="#000000" visible="true" width="4.0" x="53.0" y="78.0">
<y:LabelModel>
<y:SmartNodeLabelModel distance="4.0"/>
</y:LabelModel>
<y:ModelParameter>
<y:SmartNodeLabelModelParameter labelRatioX="0.0" labelRatioY="0.0" nodeRatioX="0.0" nodeRatioY="0.0" offsetX="0.0" offsetY="0.0" upX="0.0" upY="-1.0"/>
</y:ModelParameter>
</y:NodeLabel>
<y:Shape type="rectangle"/>
</y:ShapeNode>
</data>
</node>
<node id="n1">
<data key="d6">
<y:ShapeNode>
<y:Geometry height="10.0" width="10.0" x="171.0" y="331.0"/>
<y:Fill color="#000000" transparent="false"/>
<y:BorderStyle color="#000000" type="line" width="1.0"/>
<y:NodeLabel alignment="center" autoSizePolicy="content" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="free" modelPosition="anywhere" textColor="#000000" visible="true" width="21.1240234375" x="-4.3388671875" y="-22.701171875">S1</y:NodeLabel>
<y:Shape type="ellipse"/>
</y:ShapeNode>
</data>
</node>
<node id="n2">
<data key="d6">
<y:ShapeNode>
<y:Geometry height="10.0" width="10.0" x="171.0" y="491.0"/>
<y:Fill color="#000000" transparent="false"/>
<y:BorderStyle color="#000000" type="line" width="1.0"/>
<y:NodeLabel alignment="center" autoSizePolicy="content" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="free" modelPosition="anywhere" textColor="#000000" visible="true" width="21.1240234375" x="-5.56201171875" y="11.129404406250046">S0</y:NodeLabel>
<y:Shape type="ellipse"/>
</y:ShapeNode>
</data>
</node>
<node id="n3">
<data key="d6">
<y:ShapeNode>
<y:Geometry height="10.0" width="10.0" x="283.0" y="411.0"/>
<y:Fill color="#000000" transparent="false"/>
<y:BorderStyle color="#000000" type="line" width="1.0"/>
<y:NodeLabel alignment="center" autoSizePolicy="content" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="free" modelPosition="anywhere" textColor="#000000" visible="true" width="21.1240234375" x="2.1067891496023776" y="-26.548438091286016">S2</y:NodeLabel>
<y:Shape type="ellipse"/>
</y:ShapeNode>
</data>
</node>
<node id="n4">
<data key="d6">
<y:ShapeNode>
<y:Geometry height="158.0" width="220.81920000000002" x="385.1808" y="337.0"/>
<y:Fill color="#C0C0C0" transparent="false"/>
<y:BorderStyle hasColor="false" type="line" width="1.0"/>
<y:NodeLabel alignment="center" autoSizePolicy="content" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="custom" textColor="#000000" visible="true" width="36.6962890625" x="48.96920625000007" y="68.42431640625">S345<y:LabelModel>
<y:SmartNodeLabelModel distance="4.0"/>
</y:LabelModel>
<y:ModelParameter>
<y:SmartNodeLabelModelParameter labelRatioX="-0.5" labelRatioY="0.0" nodeRatioX="-0.27823845820472104" nodeRatioY="0.0" offsetX="0.0" offsetY="0.0" upX="0.0" upY="-1.0"/>
</y:ModelParameter>
</y:NodeLabel>
<y:Shape type="diamond"/>
</y:ShapeNode>
</data>
</node>
<node id="n5">
<data key="d6">
<y:ShapeNode>
<y:Geometry height="160.0" width="110.0" x="496.39840000000004" y="336.0"/>
<y:Fill color="#FFFFFF" transparent="false"/>
<y:BorderStyle hasColor="false" type="line" width="1.0"/>
<y:NodeLabel alignment="center" autoSizePolicy="content" fontFamily="Dialog" fontSize="12" fontStyle="plain" hasBackgroundColor="false" hasLineColor="false" hasText="false" height="4.0" modelName="custom" textColor="#000000" visible="true" width="4.0" x="53.0" y="78.0">
<y:LabelModel>
<y:SmartNodeLabelModel distance="4.0"/>
</y:LabelModel>
<y:ModelParameter>
<y:SmartNodeLabelModelParameter labelRatioX="0.0" labelRatioY="0.0" nodeRatioX="0.0" nodeRatioY="0.0" offsetX="0.0" offsetY="0.0" upX="0.0" upY="-1.0"/>
</y:ModelParameter>
</y:NodeLabel>
<y:Shape type="rectangle"/>
</y:ShapeNode>
</data>
</node>
<node id="n6">
<data key="d6">
<y:ShapeNode>
<y:Geometry height="10.0" width="10.0" x="491.0" y="331.0"/>
<y:Fill color="#000000" transparent="false"/>
<y:BorderStyle color="#000000" type="line" width="1.0"/>
<y:NodeLabel alignment="center" autoSizePolicy="content" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="free" modelPosition="anywhere" textColor="#000000" visible="true" width="21.1240234375" x="-5.56201171875" y="-22.53783399375004">S4</y:NodeLabel>
<y:Shape type="ellipse"/>
</y:ShapeNode>
</data>
</node>
<node id="n7">
<data key="d6">
<y:ShapeNode>
<y:Geometry height="10.0" width="10.0" x="379.0" y="411.0"/>
<y:Fill color="#000000" transparent="false"/>
<y:BorderStyle color="#000000" type="line" width="1.0"/>
<y:NodeLabel alignment="center" autoSizePolicy="content" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="custom" textColor="#000000" visible="true" width="21.1240234375" x="-15.1240234375" y="-26.074938684949984">S3<y:LabelModel>
<y:SmartNodeLabelModel distance="4.0"/>
</y:LabelModel>
<y:ModelParameter>
<y:SmartNodeLabelModelParameter labelRatioX="0.21596320096158295" labelRatioY="0.5" nodeRatioX="-0.5" nodeRatioY="-0.5" offsetX="0.0" offsetY="-4.923571497449984" upX="0.0" upY="-1.0"/>
</y:ModelParameter>
</y:NodeLabel>
<y:Shape type="ellipse"/>
</y:ShapeNode>
</data>
</node>
<node id="n8">
<data key="d6">
<y:ShapeNode>
<y:Geometry height="10.0" width="10.0" x="491.0" y="491.0"/>
<y:Fill color="#000000" transparent="false"/>
<y:BorderStyle color="#000000" type="line" width="1.0"/>
<y:NodeLabel alignment="center" autoSizePolicy="content" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="free" modelPosition="anywhere" textColor="#000000" visible="true" width="21.1240234375" x="-5.56201171875" y="10.057724406250031">S5</y:NodeLabel>
<y:Shape type="ellipse"/>
</y:ShapeNode>
</data>
</node>
<node id="n9">
<data key="d6">
<y:ShapeNode>
<y:Geometry height="30.0" width="74.0" x="299.0" y="497.00000000000006"/>
<y:Fill hasColor="false" transparent="false"/>
<y:BorderStyle hasColor="false" type="line" width="1.0"/>
<y:NodeLabel alignment="center" autoSizePolicy="content" fontFamily="Garamond" fontSize="16" fontStyle="plain" hasBackgroundColor="false" hasLineColor="false" height="22.0" modelName="custom" textColor="#000000" visible="true" width="54.65625" x="9.671875" y="3.999999999999943">Diabolo<y:LabelModel>
<y:SmartNodeLabelModel distance="4.0"/>
</y:LabelModel>
<y:ModelParameter>
<y:SmartNodeLabelModelParameter labelRatioX="0.0" labelRatioY="0.0" nodeRatioX="0.0" nodeRatioY="0.0" offsetX="0.0" offsetY="0.0" upX="0.0" upY="-1.0"/>
</y:ModelParameter>
</y:NodeLabel>
<y:Shape type="rectangle"/>
</y:ShapeNode>
</data>
</node>
<edge id="e0" source="n3" target="n2">
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="0.0" sy="0.0" tx="0.0" ty="0.0"/>
<y:LineStyle color="#000000" type="line" width="2.0"/>
<y:Arrows source="standard" target="none"/>
<y:EdgeLabel alignment="center" configuration="AutoFlippingLabel" distance="2.0" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="side_slider" preferredPlacement="anywhere" ratio="0.0" textColor="#000000" visible="true" width="28.91015625" x="-39.96649169921875" y="30.547494070870528">S02<y:PreferredPlacementDescriptor angle="0.0" angleOffsetOnRightSide="0" angleReference="absolute" angleRotationOnRightSide="co" distance="-1.0" frozen="true" placement="anywhere" side="anywhere" sideReference="relative_to_edge_flow"/>
</y:EdgeLabel>
<y:BendStyle smoothed="false"/>
</y:PolyLineEdge>
</data>
</edge>
<edge id="e1" source="n2" target="n1">
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="0.0" sy="0.0" tx="0.0" ty="0.0"/>
<y:LineStyle color="#000000" type="line" width="2.0"/>
<y:Arrows source="none" target="standard"/>
<y:EdgeLabel alignment="center" configuration="AutoFlippingLabel" distance="2.0" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="side_slider" preferredPlacement="anywhere" ratio="0.5" textColor="#000000" visible="true" width="28.91015625" x="-30.91015625" y="-85.57568359375">S01<y:PreferredPlacementDescriptor angle="0.0" angleOffsetOnRightSide="0" angleReference="absolute" angleRotationOnRightSide="co" distance="-1.0" frozen="true" placement="anywhere" side="anywhere" sideReference="relative_to_edge_flow"/>
</y:EdgeLabel>
<y:BendStyle smoothed="false"/>
</y:PolyLineEdge>
</data>
</edge>
<edge id="e2" source="n3" target="n1">
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="0.0" sy="0.0" tx="0.0" ty="0.0"/>
<y:LineStyle color="#000000" type="line" width="2.0"/>
<y:Arrows source="standard" target="none"/>
<y:EdgeLabel alignment="center" configuration="AutoFlippingLabel" distance="2.0" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="side_slider" preferredPlacement="anywhere" ratio="0.5" textColor="#000000" visible="true" width="28.91015625" x="-66.38641357421875" y="-70.5702340262277">S12<y:PreferredPlacementDescriptor angle="0.0" angleOffsetOnRightSide="0" angleReference="absolute" angleRotationOnRightSide="co" distance="-1.0" frozen="true" placement="anywhere" side="anywhere" sideReference="relative_to_edge_flow"/>
</y:EdgeLabel>
<y:BendStyle smoothed="false"/>
</y:PolyLineEdge>
</data>
</edge>
<edge id="e3" source="n3" target="n7">
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="0.0" sy="0.0" tx="0.0" ty="0.0"/>
<y:LineStyle color="#000000" type="line" width="2.0"/>
<y:Arrows source="none" target="standard"/>
<y:EdgeLabel alignment="center" configuration="AutoFlippingLabel" distance="2.0" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="side_slider" preferredPlacement="anywhere" ratio="0.5" textColor="#000000" visible="true" width="28.91015625" x="28.544921875" y="2.0">S23<y:PreferredPlacementDescriptor angle="0.0" angleOffsetOnRightSide="0" angleReference="absolute" angleRotationOnRightSide="co" distance="-1.0" frozen="true" placement="anywhere" side="anywhere" sideReference="relative_to_edge_flow"/>
</y:EdgeLabel>
<y:BendStyle smoothed="false"/>
</y:PolyLineEdge>
</data>
</edge>
<edge id="e4" source="n7" target="n6">
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="0.0" sy="0.0" tx="0.0" ty="0.0"/>
<y:LineStyle color="#000000" type="line" width="2.0"/>
<y:Arrows source="none" target="standard"/>
<y:EdgeLabel alignment="center" configuration="AutoFlippingLabel" distance="2.0" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="side_slider" preferredPlacement="anywhere" ratio="0.0" textColor="#000000" visible="true" width="28.91015625" x="11.05633544921875" y="-51.69886125837053">S34<y:PreferredPlacementDescriptor angle="0.0" angleOffsetOnRightSide="0" angleReference="absolute" angleRotationOnRightSide="co" distance="-1.0" frozen="true" placement="anywhere" side="anywhere" sideReference="relative_to_edge_flow"/>
</y:EdgeLabel>
<y:BendStyle smoothed="false"/>
</y:PolyLineEdge>
</data>
</edge>
<edge id="e5" source="n8" target="n7">
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="0.0" sy="0.0" tx="0.0" ty="0.0"/>
<y:LineStyle color="#000000" type="line" width="2.0"/>
<y:Arrows source="standard" target="none"/>
<y:EdgeLabel alignment="center" configuration="AutoFlippingLabel" distance="2.0" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="side_slider" preferredPlacement="anywhere" ratio="1.0" textColor="#000000" visible="true" width="28.91015625" x="-92.80633544921875" y="-43.64012799944197">S35<y:PreferredPlacementDescriptor angle="0.0" angleOffsetOnRightSide="0" angleReference="absolute" angleRotationOnRightSide="co" distance="-1.0" frozen="true" placement="anywhere" side="anywhere" sideReference="relative_to_edge_flow"/>
</y:EdgeLabel>
<y:BendStyle smoothed="false"/>
</y:PolyLineEdge>
</data>
</edge>
<edge id="e6" source="n6" target="n8">
<data key="d10">
<y:PolyLineEdge>
<y:Path sx="0.0" sy="0.0" tx="0.0" ty="0.0"/>
<y:LineStyle color="#000000" type="line" width="2.0"/>
<y:Arrows source="none" target="standard"/>
<y:EdgeLabel alignment="center" configuration="AutoFlippingLabel" distance="2.0" fontFamily="Dialog" fontSize="14" fontStyle="bold" hasBackgroundColor="false" hasLineColor="false" height="21.1513671875" modelName="side_slider" preferredPlacement="anywhere" ratio="0.5" textColor="#000000" visible="true" width="28.91015625" x="2.0" y="64.42431640625">S45<y:PreferredPlacementDescriptor angle="0.0" angleOffsetOnRightSide="0" angleReference="absolute" angleRotationOnRightSide="co" distance="-1.0" frozen="true" placement="anywhere" side="anywhere" sideReference="relative_to_edge_flow"/>
</y:EdgeLabel>
<y:BendStyle smoothed="false"/>
</y:PolyLineEdge>
</data>
</edge>
</graph>
<data key="d7">
<y:Resources/>
</data>
</graphml>

117
examples/diabolo.svg Normal file
View File

@ -0,0 +1,117 @@
<?xml version="1.0" encoding="UTF-8"?><svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" fill-opacity="1" color-rendering="auto" color-interpolation="auto" text-rendering="auto" stroke="black" stroke-linecap="square" width="573" stroke-miterlimit="10" shape-rendering="auto" stroke-opacity="1" fill="black" stroke-dasharray="none" font-weight="normal" stroke-width="1" height="249" font-family="'Dialog'" font-style="normal" stroke-linejoin="miter" font-size="12px" stroke-dashoffset="0" image-rendering="auto">
<!--Generated by ySVG 2.5-->
<defs id="genericDefs"/>
<g>
<defs id="defs1">
<clipPath clipPathUnits="userSpaceOnUse" id="clipPath1">
<path d="M0 0 L573 0 L573 249 L0 249 L0 0 Z"/>
</clipPath>
<clipPath clipPathUnits="userSpaceOnUse" id="clipPath2">
<path d="M49 293 L622 293 L622 542 L49 542 L49 293 Z"/>
</clipPath>
</defs>
<g fill="white" text-rendering="geometricPrecision" shape-rendering="geometricPrecision" transform="translate(-49,-293)" stroke="white">
<rect x="49" width="573" height="249" y="293" clip-path="url(#clipPath2)" stroke="none"/>
</g>
<g fill="white" text-rendering="geometricPrecision" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)" stroke="white">
<rect x="64.8643" width="110" height="160" y="336" clip-path="url(#clipPath2)" stroke="none"/>
<circle fill="black" r="5" clip-path="url(#clipPath2)" cx="176" cy="336" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="168.6611" xml:space="preserve" y="324.374" clip-path="url(#clipPath2)" stroke="none">S1</text>
<circle fill="none" r="5" clip-path="url(#clipPath2)" cx="176" cy="336"/>
</g>
<g text-rendering="geometricPrecision" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)">
<circle r="5" clip-path="url(#clipPath2)" cx="176" cy="496" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="167.438" xml:space="preserve" y="518.2046" clip-path="url(#clipPath2)" stroke="none">S0</text>
<circle fill="none" r="5" clip-path="url(#clipPath2)" cx="176" cy="496"/>
</g>
<g text-rendering="geometricPrecision" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)">
<circle r="5" clip-path="url(#clipPath2)" cx="288" cy="416" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="287.1068" xml:space="preserve" y="400.5268" clip-path="url(#clipPath2)" stroke="none">S2</text>
<circle fill="none" r="5" clip-path="url(#clipPath2)" cx="288" cy="416"/>
</g>
<g fill="silver" text-rendering="geometricPrecision" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)" stroke="silver">
<path d="M385.1808 416 L495.5904 337 L606 416 L495.5904 495 Z" fill-rule="evenodd" clip-path="url(#clipPath2)" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="436.15" xml:space="preserve" y="421.4995" clip-path="url(#clipPath2)" stroke="none">S345</text>
</g>
<g fill="white" text-rendering="geometricPrecision" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)" stroke="white">
<rect x="496.3984" width="110" height="160" y="336" clip-path="url(#clipPath2)" stroke="none"/>
<circle fill="black" r="5" clip-path="url(#clipPath2)" cx="496" cy="336" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="487.438" xml:space="preserve" y="324.5374" clip-path="url(#clipPath2)" stroke="none">S4</text>
<circle fill="none" r="5" clip-path="url(#clipPath2)" cx="496" cy="336"/>
</g>
<g text-rendering="geometricPrecision" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)">
<circle r="5" clip-path="url(#clipPath2)" cx="384" cy="416" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="365.876" xml:space="preserve" y="401.0002" clip-path="url(#clipPath2)" stroke="none">S3</text>
<circle fill="none" r="5" clip-path="url(#clipPath2)" cx="384" cy="416"/>
</g>
<g text-rendering="geometricPrecision" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)">
<circle r="5" clip-path="url(#clipPath2)" cx="496" cy="496" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="487.438" xml:space="preserve" y="517.1329" clip-path="url(#clipPath2)" stroke="none">S5</text>
<circle fill="none" r="5" clip-path="url(#clipPath2)" cx="496" cy="496"/>
<text x="310.6719" font-size="16px" y="516.7891" clip-path="url(#clipPath2)" font-family="'Garamond'" stroke="none" font-weight="normal" xml:space="preserve">Diabolo</text>
</g>
<g text-rendering="geometricPrecision" stroke-miterlimit="1.45" stroke-width="2" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)" stroke-linecap="butt">
<path fill="none" d="M176 491 L176 350" clip-path="url(#clipPath2)"/>
<path d="M176 341 L170.375 354.5 L176 351.125 L181.625 354.5 Z" clip-path="url(#clipPath2)" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="147.0898" xml:space="preserve" y="421.4995" clip-path="url(#clipPath2)" stroke="none">S01</text>
</g>
<g text-rendering="geometricPrecision" stroke-miterlimit="1.45" stroke-width="2" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)" stroke-linecap="butt">
<path fill="none" d="M276.6077 424.1373 L180.0687 493.0938" clip-path="url(#clipPath2)"/>
<path d="M283.9313 418.9062 L269.6765 422.1756 L275.6923 424.7912 L276.2154 431.3301 Z" clip-path="url(#clipPath2)" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="245.9648" xml:space="preserve" y="465.5289" clip-path="url(#clipPath2)" stroke="none">S02</text>
</g>
<g text-rendering="geometricPrecision" stroke-miterlimit="1.45" stroke-width="2" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)" stroke-linecap="butt">
<path fill="none" d="M276.6077 407.8627 L180.0687 338.9062" clip-path="url(#clipPath2)"/>
<path d="M283.9313 413.0938 L276.2154 400.6699 L275.6923 407.2088 L269.6765 409.8244 Z" clip-path="url(#clipPath2)" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="219.5449" xml:space="preserve" y="358.5988" clip-path="url(#clipPath2)" stroke="none">S12</text>
</g>
<g text-rendering="geometricPrecision" stroke-miterlimit="1.45" stroke-width="2" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)" stroke-linecap="butt">
<path fill="none" d="M293 416 L370 416" clip-path="url(#clipPath2)"/>
<path d="M379 416 L365.5 410.375 L368.875 416 L365.5 421.625 Z" clip-path="url(#clipPath2)" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="323.5449" xml:space="preserve" y="434.0752" clip-path="url(#clipPath2)" stroke="none">S23</text>
</g>
<g text-rendering="geometricPrecision" stroke-miterlimit="1.45" stroke-width="2" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)" stroke-linecap="butt">
<path fill="none" d="M388.0687 413.0938 L484.6077 344.1373" clip-path="url(#clipPath2)"/>
<path d="M491.9313 338.9062 L477.6765 342.1756 L483.6923 344.7912 L484.2154 351.3301 Z" clip-path="url(#clipPath2)" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="401.125" xml:space="preserve" y="377.4702" clip-path="url(#clipPath2)" stroke="none">S34</text>
</g>
<g text-rendering="geometricPrecision" stroke-miterlimit="1.45" stroke-width="2" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)" stroke-linecap="butt">
<path fill="none" d="M496 341 L496 482" clip-path="url(#clipPath2)"/>
<path d="M496 491 L501.625 477.5 L496 480.875 L490.375 477.5 Z" clip-path="url(#clipPath2)" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="500" xml:space="preserve" y="421.4995" clip-path="url(#clipPath2)" stroke="none">S45</text>
</g>
<g text-rendering="geometricPrecision" stroke-miterlimit="1.45" stroke-width="2" shape-rendering="geometricPrecision" transform="matrix(1,0,0,1,-49,-293)" stroke-linecap="butt">
<path fill="none" d="M484.6077 487.8627 L388.0687 418.9062" clip-path="url(#clipPath2)"/>
<path d="M491.9313 493.0938 L484.2154 480.6699 L483.6923 487.2088 L477.6765 489.8244 Z" clip-path="url(#clipPath2)" stroke="none"/>
</g>
<g font-size="14px" stroke-linecap="butt" transform="matrix(1,0,0,1,-49,-293)" text-rendering="geometricPrecision" font-family="sans-serif" shape-rendering="geometricPrecision" font-weight="bold" stroke-miterlimit="1.45">
<text x="401.125" xml:space="preserve" y="465.5289" clip-path="url(#clipPath2)" stroke="none">S35</text>
</g>
</g>
</svg>
Side by Side

After

Width:  |  Height:  |  Size: 11 KiB

96
kenzo-test.asd
View File

@ -1,50 +1,50 @@
(defsystem :kenzo-test (defsystem :kenzo-test
:description "A simple regression test suite for Kenzo" :description "A simple regression test suite for Kenzo"
:serial t :serial t
:version "0.1.0" :version "0.1.0"
:author "Francis Sergeraert <Francis.Sergeraert@ujf-grenoble.fr>" :author "Francis Sergeraert <Francis.Sergeraert@ujf-grenoble.fr>"
:license "GPLv3" :license "GPLv3"
:depends-on (:kenzo :fiveam) :depends-on (:kenzo :fiveam)
:pathname #P"test/" :pathname #P"test/"
:components ((:file "package") :components ((:file "package")
(:file "common") (:file "common")
;; === test files === ;; === test files ===
(:file "bar-test") (:file "bar-test")
(:file "bicones-test") (:file "bicones-test")
(:file "cartesian-products-test") (:file "cartesian-products-test")
(:file "ccn") (:file "ccn")
(:file "chain-complexes-test") (:file "chain-complexes-test")
(:file "chcm-elementary-op-test") (:file "chcm-elementary-op-test")
(:file "circle") (:file "circle")
(:file "cl-space-efhm-test") (:file "cl-space-efhm-test")
(:file "classifying-spaces-test") (:file "classifying-spaces-test")
(:file "cobar-test") (:file "cobar-test")
(:file "combinations-test") (:file "combinations-test")
(:file "cones-test") (:file "cones-test")
(:file "cs-twisted-products-test") (:file "cs-twisted-products-test")
(:file "delta-test") (:file "delta-test")
(:file "diabolo") (:file "diabolo")
(:file "disk-pasting-test") (:file "disk-pasting-test")
(:file "eilenberg-zilber-test") (:file "eilenberg-zilber-test")
(:file "effective-homology-test") (:file "effective-homology-test")
(:file "fibrations-test") (:file "fibrations-test")
(:file "homology-groups-test") (:file "homology-groups-test")
(:file "k-pi-n-test") (:file "k-pi-n-test")
(:file "kan-test") (:file "kan-test")
(:file "loop-spaces-test") (:file "loop-spaces-test")
(:file "lp-space-efhm-test") (:file "lp-space-efhm-test")
(:file "ls-twisted-products-test") (:file "ls-twisted-products-test")
(:file "macros-test") (:file "macros-test")
(:file "searching-homology-test") (:file "searching-homology-test")
(:file "serre-test") (:file "serre-test")
(:file "simplicial-groups-test") (:file "simplicial-groups-test")
(:file "simplicial-mrphs-test") (:file "simplicial-mrphs-test")
(:file "simplicial-sets-test") (:file "simplicial-sets-test")
(:file "smith-test") (:file "smith-test")
(:file "special-smsts-test") (:file "special-smsts-test")
(:file "suspensions-test") (:file "suspensions-test")
(:file "tensor-products-test") (:file "tensor-products-test")
(:file "various-test") (:file "various-test")
(:file "whitehead-test") (:file "whitehead-test")
)) ))

1146
package.lisp
View File

File diff suppressed because it is too large Load Diff

6
src/cat-init.lisp
View File

@ -60,8 +60,8 @@
(format t "~% FILE ~2D: ~A" i (car mark))) (format t "~% FILE ~2D: ~A" i (car mark)))
(DEFCONSTANT +SOURCE-EXTENSION+ (DEFCONSTANT +SOURCE-EXTENSION+
#+(or allegro clisp lispworks) "cl" #+(or allegro lispworks) "cl"
#+(or ccl ecl sbcl) "lisp" #+(or clisp ccl ecl sbcl) "lisp"
#-(or allegro ccl clisp ecl lispworks sbcl) #-(or allegro ccl clisp ecl lispworks sbcl)
(error "Not an Allegro or CCL or CLisp or LispWorks or SBCL environment.")) (error "Not an Allegro or CCL or CLisp or LispWorks or SBCL environment."))
@ -79,6 +79,8 @@
(DEFVAR *CMBN-CONTROL*) (DEFVAR *CMBN-CONTROL*)
(SETF *CMBN-CONTROL* T) (SETF *CMBN-CONTROL* T)
#+SBCL (DECLAIM (SB-EXT:MUFFLE-CONDITIONS style-warning compiler-note))
(DEFUN COMPILE-FILES () (DEFUN COMPILE-FILES ()
(format t "~%*CMBN-CONTROL* = ~A~2%" *cmbn-control*) (format t "~%*CMBN-CONTROL* = ~A~2%" *cmbn-control*)
(mapc #'(lambda (file-name) (mapc #'(lambda (file-name)

488
src/chain-complexes.lisp
View File

@ -31,13 +31,13 @@ Args: ()
Return the number of user created objects by object type. Return the number of user created objects by object type.
------------------------------------------------------------------------------" ------------------------------------------------------------------------------"
(mapc #'(lambda (symbol) (mapc #'(lambda (symbol)
(declare (type (or string symbol) symbol)) (declare (type (or string symbol) symbol))
(let ((length (length (eval symbol)))) (let ((length (length (eval symbol))))
(declare (fixnum length)) (declare (fixnum length))
(setf symbol (symbol-name symbol)) (setf symbol (symbol-name symbol))
(setf symbol (subseq symbol 1 (- (length symbol) 6))) (setf symbol (subseq symbol 1 (- (length symbol) 6)))
(format t "~%~6D ~As" length symbol))) (format t "~%~6D ~As" length symbol)))
*list-list*) *list-list*)
(done)) (done))
@ -48,12 +48,12 @@ Args: ()
Return a string representation of a user created objects. Return a string representation of a user created objects.
------------------------------------------------------------------------------" ------------------------------------------------------------------------------"
(let ((object-list (let ((object-list
(sort (delete-duplicates (sort (delete-duplicates
(mapcan #'(lambda (symbol) (mapcan #'(lambda (symbol)
(copy-list (eval symbol))) (copy-list (eval symbol)))
*list-list*) *list-list*)
:test #'eq) :test #'eq)
#'< :key #'idnm))) #'< :key #'idnm)))
(declare (list object-list)) (declare (list object-list))
(dolist (item object-list) (dolist (item object-list)
(format t "~%~A = ~A" item (orgn item)))) (format t "~%~A = ~A" item (orgn item))))
@ -71,9 +71,9 @@ Return the type of Kenzo object number IDNM and print the comment list
(dolist (list *list-list*) (dolist (list *list-list*)
(let ((found (find idnm (eval list) :key #'idnm))) (let ((found (find idnm (eval list) :key #'idnm)))
(when found (when found
(format t "~%Object: ~A (format t "~%Object: ~A
~3TOrigin: ~A~2%" found (orgn found)) ~3TOrigin: ~A~2%" found (orgn found))
(return-from kd (values)))))) (return-from kd (values))))))
(DEFUN K (idnm) (DEFUN K (idnm)
@ -86,7 +86,7 @@ Returns the IDNM-th Kenzo object.
(dolist (list *list-list*) (dolist (list *list-list*)
(let ((found (find idnm (eval list) :key #'idnm))) (let ((found (find idnm (eval list) :key #'idnm)))
(when found (when found
(return-from k found))))) (return-from k found)))))
(DEFUN KD2 (idnm) (DEFUN KD2 (idnm)
@ -104,16 +104,16 @@ the list of object numbers.
(return-from kd2 nil)) (return-from kd2 nil))
(setf k-list (list k-list)) (setf k-list (list k-list))
(do ((idnm (1- idnm) (1- idnm))) (do ((idnm (1- idnm) (1- idnm)))
((zerop idnm)) ((zerop idnm))
(declare (fixnum idnm)) (declare (fixnum idnm))
(let ((found (find-if (let ((found (find-if
#'(lambda (item) #'(lambda (item)
(declare (type (or chain-complex morphism) item)) (declare (type (or chain-complex morphism) item))
(member (k idnm) (orgn item))) (member (k idnm) (orgn item)))
k-list))) k-list)))
(declare (type (or null chain-complex morphism) found)) (declare (type (or null chain-complex morphism) found))
(when found (when found
(push (k idnm) k-list)))) (push (k idnm) k-list))))
(mapc #'kd (nreverse (mapcar #'idnm k-list))))) (mapc #'kd (nreverse (mapcar #'idnm k-list)))))
@ -122,8 +122,8 @@ the list of object numbers.
(DEFMETHOD PRINT-OBJECT ((chcm chain-complex) stream) (DEFMETHOD PRINT-OBJECT ((chcm chain-complex) stream)
(the chain-complex (the chain-complex
(progn (progn
(format stream "[K~D Chain-Complex]" (idnm chcm)) (format stream "[K~D Chain-Complex]" (idnm chcm))
chcm))) chcm)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -149,8 +149,8 @@ identifier IDNUM or NIL, if it doesn't exist.
~3TVALUE-> ~A ~3TVALUE-> ~A
~4TCLNM-> ~6D ~4TCLNM-> ~6D
~4TRNTM-> ~11,3F" ~4TRNTM-> ~11,3F"
(result-gnrt result) (result-value result) (result-gnrt result) (result-value result)
(result-clnm result) (result-rntm result)) (result-clnm result) (result-rntm result))
result) result)
@ -193,12 +193,12 @@ identifier IDNUM or NIL, if it doesn't exist.
(DEFMETHOD PRINT-OBJECT ((mrph morphism) stream) (DEFMETHOD PRINT-OBJECT ((mrph morphism) stream)
(the morphism (the morphism
(progn (progn
(if (eq (first (orgn (trgt mrph))) 'z-chcm) (if (eq (first (orgn (trgt mrph))) 'z-chcm)
(format stream "[K~D Cohomology-Class on K~D of degree ~D]" (format stream "[K~D Cohomology-Class on K~D of degree ~D]"
(idnm mrph) (idnm (sorc mrph)) (- (degr mrph))) (idnm mrph) (idnm (sorc mrph)) (- (degr mrph)))
(format stream "[K~D Morphism (degree ~D): K~D -> K~D]" (format stream "[K~D Morphism (degree ~D): K~D -> K~D]"
(idnm mrph) (degr mrph) (idnm mrph) (degr mrph)
(idnm (sorc mrph)) (idnm (trgt mrph)))) (idnm (sorc mrph)) (idnm (trgt mrph))))
mrph))) mrph)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -239,10 +239,12 @@ follows:
of the differential homomorphism, either by generator or by of the differential homomorphism, either by generator or by
combination. The default is :GNRT combination. The default is :GNRT
:ORGN ORGN, a list containing a relevant and carefully chosen comment about :ORGN ORGN, a list which is the copy of a Lisp statement, in principle the
the origin of the chain complex. This comment should be unique statement which was at the origin of the creation of this Kenzo
for a Kenzo session (between calls of CAT-INIT), as it is used object. A caching process, using this slot, prevents the creation
for caching purposes. of multiple copies of the same mathematical object, which is
important for efficiency. It is used also for debugging and
analyzing the program.
Use this function instead of creating instances via the standard constructor Use this function instead of creating instances via the standard constructor
MAKE-INSTANCE. MAKE-INSTANCE.
@ -250,25 +252,25 @@ MAKE-INSTANCE.
(the chain-complex (the chain-complex
(progn (progn
(let ((already (find orgn *chcm-list* :test #'equal :key #'orgn))) (let ((already (find orgn *chcm-list* :test #'equal :key #'orgn)))
(declare (type (or chain-complex null) already)) (declare (type (or chain-complex null) already))
(when already (when already
(return-from build-chcm already))) (return-from build-chcm already)))
(unless basis (unless basis
(setf basis :locally-effective)) (setf basis :locally-effective))
(let ((chcm (make-instance 'chain-complex (let ((chcm (make-instance 'chain-complex
:cmpr cmpr :cmpr cmpr
:basis basis :basis basis
:bsgn bsgn :bsgn bsgn
:orgn orgn))) :orgn orgn)))
(declare (type chain-complex chcm)) (declare (type chain-complex chcm))
(setf (slot-value chcm 'dffr) (setf (slot-value chcm 'dffr)
(build-mrph (build-mrph
:sorc chcm :trgt chcm :degr -1 :sorc chcm :trgt chcm :degr -1
:intr intr-dffr :strt strt :intr intr-dffr :strt strt
:orgn `(dffr ,chcm))) :orgn `(dffr ,chcm)))
(setf (slot-value chcm 'grmd) chcm) (setf (slot-value chcm 'grmd) chcm)
(push chcm *chcm-list*) (push chcm *chcm-list*)
chcm)))) chcm))))
(DEFUN BASIS2 (object n) ;;; (DEFUN BASIS2 (object n) ;;;
@ -279,7 +281,7 @@ MAKE-INSTANCE.
(with-slots (basis) object (with-slots (basis) object
(declare (type basis basis)) (declare (type basis basis))
(when (eq :locally-effective basis) (when (eq :locally-effective basis)
(error "The object ~A is locally-effective." object)) (error "The object ~A is locally-effective." object))
(funcall basis n)))) (funcall basis n))))
@ -308,10 +310,12 @@ follows:
of the differential homomorphism, either by generator or by of the differential homomorphism, either by generator or by
combination. The default is :GNRT combination. The default is :GNRT
:ORGN ORGN, a list containing a relevant and carefully chosen comment about :ORGN ORGN, a list which is the copy of a Lisp statement, in principle the
the origin of the chain complex. This comment should be unique statement which was at the origin of the creation of this Kenzo
for a Kenzo session (between calls of CAT-INIT), as it is used object. A caching process, using this slot, prevents the creation
for caching purposes. of multiple copies of the same mathematical object, which is
important for efficiency. It is used also for debugging and
analyzing the program.
Use this function instead of creating instances via the standard constructor Use this function instead of creating instances via the standard constructor
MAKE-INSTANCE. MAKE-INSTANCE.
@ -319,63 +323,63 @@ MAKE-INSTANCE.
(the morphism (the morphism
(progn (progn
(let ((already (find orgn *mrph-list* :test #'equal :key #'orgn))) (let ((already (find orgn *mrph-list* :test #'equal :key #'orgn)))
(declare (type (or morphism null) already)) (declare (type (or morphism null) already))
(when already (when already
(return-from build-mrph already))) (return-from build-mrph already)))
(let ((mrph (make-instance 'morphism (let ((mrph (make-instance 'morphism
:sorc sorc :trgt trgt :degr degr :sorc sorc :trgt trgt :degr degr
:intr intr :strt strt :intr intr :strt strt
:orgn orgn))) :orgn orgn)))
(declare (type morphism mrph)) (declare (type morphism mrph))
(setf (slot-value mrph 'rslts) (setf (slot-value mrph 'rslts)
(ecase strt (ecase strt
(:gnrt (map 'simple-vector (:gnrt (map 'simple-vector
;; (vector (vector result)) ;; (vector (vector result))
#'(lambda (dummy) #'(lambda (dummy)
(declare (ignore dummy)) (declare (ignore dummy))
(make-array 0 (make-array 0
:adjustable t :adjustable t
:fill-pointer 0)) :fill-pointer 0))
(make-list +maximal-dimension+))) (make-list +maximal-dimension+)))
(:cmbn (make-array 0)))) (:cmbn (make-array 0))))
(push mrph *mrph-list*) (push mrph *mrph-list*)
mrph)))) mrph))))
;;; FUNCTIONS ;;; FUNCTIONS
(DEFUN NRESULTS () (DEFUN NRESULTS ()
(the fixnum (the fixnum
(let ((nrslts 0)) (let ((nrslts 0))
(declare (fixnum nrslts)) (declare (fixnum nrslts))
(dolist (item *mrph-list*) (dolist (item *mrph-list*)
(declare (type morphism item)) (declare (type morphism item))
(when (eq :gnrt (strt item)) (when (eq :gnrt (strt item))
(map nil (map nil
#'(lambda (drslt) #'(lambda (drslt)
(declare (vector drslt)) (declare (vector drslt))
(incf nrslts (length drslt))) (incf nrslts (length drslt)))
(rslts item)))) (rslts item))))
nrslts))) nrslts)))
(DEFUN TIME-LIST () (DEFUN TIME-LIST ()
(the list (the list
(let ((time-list +empty-list+)) (let ((time-list +empty-list+))
(declare (list time-list)) (declare (list time-list))
(dolist (item *mrph-list*) (dolist (item *mrph-list*)
(declare (type morphism item)) (declare (type morphism item))
(when (eq :gnrt (strt item)) (when (eq :gnrt (strt item))
(map nil #'(lambda (drslt) (map nil #'(lambda (drslt)
(declare (vector drslt)) (declare (vector drslt))
(map nil #'(lambda (rslt) (map nil #'(lambda (rslt)
(declare (type result rslt)) (declare (type result rslt))
(let ((rntm (result-rntm rslt))) (let ((rntm (result-rntm rslt)))
(declare (single-float rntm)) (declare (single-float rntm))
(when (plusp rntm) (when (plusp rntm)
(push rntm time-list)))) (push rntm time-list))))
drslt)) drslt))
(rslts item)))) (rslts item))))
(sort time-list #'>)))) (sort time-list #'>))))
(DEFUN CLEAN-RESULTS (&optional (results-coef *results-coef*)) (DEFUN CLEAN-RESULTS (&optional (results-coef *results-coef*))
@ -384,35 +388,35 @@ MAKE-INSTANCE.
(special *results-coef* *results-cmlt-tm* *results-n* *results-verbose*)) (special *results-coef* *results-cmlt-tm* *results-n* *results-verbose*))
(the (values ) (the (values )
(let ((cut (* results-coef (/ *results-cmlt-tm* *results-n*)))) (let ((cut (* results-coef (/ *results-cmlt-tm* *results-n*))))
(declare (single-float cut)) (declare (single-float cut))
(setf *results-n* 0 *results-cmlt-tm* 0.0) (setf *results-n* 0 *results-cmlt-tm* 0.0)
(dolist (item *mrph-list*) (dolist (item *mrph-list*)
(declare (type morphism item)) (declare (type morphism item))
(when (eq :gnrt (strt item)) (when (eq :gnrt (strt item))
(let ((rslts (rslts item))) (let ((rslts (rslts item)))
(declare (vector rslts)) (declare (vector rslts))
(dotimes (i +maximal-dimension+) (dotimes (i +maximal-dimension+)
(declare (fixnum i)) (declare (fixnum i))
(let ((rslts-i (aref rslts i)) (let ((rslts-i (aref rslts i))
(output (make-array 0 :adjustable t :fill-pointer 0))) (output (make-array 0 :adjustable t :fill-pointer 0)))
(declare (vector rslts-i output)) (declare (vector rslts-i output))
(map nil (map nil
#'(lambda (rslt) #'(lambda (rslt)
(declare (type result rslt)) (declare (type result rslt))
(let ((rntm (result-rntm rslt))) (let ((rntm (result-rntm rslt)))
(declare (single-float rntm)) (declare (single-float rntm))
(when (> rntm cut) (when (> rntm cut)
(incf *results-n*) (incf *results-n*)
(incf *results-cmlt-tm* rntm) (incf *results-cmlt-tm* rntm)
(vector-push-extend rslt output)))) (vector-push-extend rslt output))))
rslts-i) rslts-i)
(setf (aref rslts i) output)))))) (setf (aref rslts i) output))))))
(when *results-verbose* (when *results-verbose*
(format t "~%*CR* -- Cut = ~A -- N = ~A" cut *results-n*))))) (format t "~%*CR* -- Cut = ~A -- N = ~A" cut *results-n*)))))
(DEFUN MRPH-GNRT (cmpr2 intr degr gnrt memory (DEFUN MRPH-GNRT (cmpr2 intr degr gnrt memory
&optional (left -1) (right (fill-pointer memory))) &optional (left -1) (right (fill-pointer memory)))
(declare (declare
(type intr-mrph intr) (type intr-mrph intr)
;; (function (fixnum gnrt) cmbn) ;; (function (fixnum gnrt) cmbn)
@ -427,47 +431,47 @@ MAKE-INSTANCE.
;; cmbn = image of the generator ;; cmbn = image of the generator
;; fixnum = index "exact" or just "lower" of the maybe stored result ;; fixnum = index "exact" or just "lower" of the maybe stored result
(loop (loop
(when (= right (1+ left)) ; the result for gnrt is not available (when (= right (1+ left)) ; the result for gnrt is not available
(push (get-internal-run-time) *start-stack*) (push (get-internal-run-time) *start-stack*)
(let ((value (funcall intr degr gnrt)) (let ((value (funcall intr degr gnrt))
(runtime (- (get-internal-run-time) (pop *start-stack*)))) (runtime (- (get-internal-run-time) (pop *start-stack*))))
(declare (declare
(type cmbn value) (type cmbn value)
(integer runtime)) (integer runtime))
(if (> runtime +too-much-time+) (if (> runtime +too-much-time+)
;; the condition deciding whether ;; the condition deciding whether
;; storing must happen ;; storing must happen
(let ((old-length (vector-push-extend nil memory))) (let ((old-length (vector-push-extend nil memory)))
(declare (fixnum old-length)) (declare (fixnum old-length))
(replace memory memory (replace memory memory
:start1 (1+ right) :end1 (1+ old-length) :start1 (1+ right) :end1 (1+ old-length)
:start2 right :end2 old-length) :start2 right :end2 old-length)
(setf (aref memory right) (setf (aref memory right)
(make-result (make-result
:gnrt gnrt :value value :clnm 1 :gnrt gnrt :value value :clnm 1
:rntm (let ((rntm :rntm (let ((rntm
(float (float
(/ runtime (/ runtime
internal-time-units-per-second)))) internal-time-units-per-second))))
(declare (single-float rntm)) (declare (single-float rntm))
(incf *results-cmlt-tm* rntm) (incf *results-cmlt-tm* rntm)
rntm))) rntm)))
(mapl #'(lambda (mark) (mapl #'(lambda (mark)
(declare (cons mark)) (declare (cons mark))
(incf (car mark) runtime)) (incf (car mark) runtime))
*start-stack*) *start-stack*)
(when (> (incf *results-n*) *results-max*) (when (> (incf *results-n*) *results-max*)
(clean-results)) (clean-results))
(return (values value right))) (return (values value right)))
(return (values value left))))) (return (values value left)))))
(let ((middle (truncate (+ right left) 2))) (let ((middle (truncate (+ right left) 2)))
(declare (fixnum middle)) (declare (fixnum middle))
(ecase (funcall cmpr2 gnrt (result-gnrt (aref memory middle))) (ecase (funcall cmpr2 gnrt (result-gnrt (aref memory middle)))
(:equal (let ((rslt (aref memory middle))) (:equal (let ((rslt (aref memory middle)))
(declare (type result rslt)) (declare (type result rslt))
(incf (result-clnm rslt)) (incf (result-clnm rslt))
(return (values (result-value rslt) middle)))) (return (values (result-value rslt) middle))))
(:less (setf right middle)) (:less (setf right middle))
(:greater (setf left middle))))))) (:greater (setf left middle)))))))
@ -481,17 +485,17 @@ MAKE-INSTANCE.
;; (vector result) ;; (vector result)
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((n-cmbn-list +empty-list+)) (let ((n-cmbn-list +empty-list+))
(declare (list n-cmbn-list)) (declare (list n-cmbn-list))
(do ((mark list (cdr mark)) (do ((mark list (cdr mark))
(left -1)) (left -1))
((endp mark)) ((endp mark))
(declare (list mark)) (declare (list mark))
(multiple-value-bind (rslt new-left) (multiple-value-bind (rslt new-left)
(mrph-gnrt scmpr2 intr degr (-gnrt mark) memory left) (mrph-gnrt scmpr2 intr degr (-gnrt mark) memory left)
(setf left new-left) (setf left new-left)
(push (cons (-cffc mark) rslt) n-cmbn-list))) (push (cons (-cffc mark) rslt) n-cmbn-list)))
(cmbn-cmbn tcmpr2 n-cmbn-list))))) (cmbn-cmbn tcmpr2 n-cmbn-list)))))
(DEFUN DO-CONTROL (cmpr cmbn) (DEFUN DO-CONTROL (cmpr cmbn)
(declare (declare
@ -501,14 +505,14 @@ MAKE-INSTANCE.
(let ((list (cmbn-list cmbn))) (let ((list (cmbn-list cmbn)))
(declare (list list)) (declare (list list))
(do ((mark1 (rest list) (cdr mark1)) (do ((mark1 (rest list) (cdr mark1))
(mark2 list mark1)) (mark2 list mark1))
((endp mark1)) ((endp mark1))
(declare (list mark1 mark2)) (declare (list mark1 mark2))
(unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1))) (unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1)))
(setf *wrong-cmbn* cmbn) (setf *wrong-cmbn* cmbn)
(error "In the combination located by *WRONG-CMBN*, the generators:~@ (error "In the combination located by *WRONG-CMBN*, the generators:~@
~A and ~A are in a wrong order." (cdar mark2) ~A and ~A are in a wrong order." (cdar mark2)
(cdar mark1)))))) (cdar mark1))))))
cmbn) cmbn)
#| #|
@ -517,9 +521,9 @@ MAKE-INSTANCE.
(DEFUN PROFILER-INIT () (DEFUN PROFILER-INIT ()
(mapc #'(lambda (mrph) (mapc #'(lambda (mrph)
(declare (type morphism mrph)) (declare (type morphism mrph))
(setf (wrtm mrph) 0)) (setf (wrtm mrph) 0))
*mrph-list*)) *mrph-list*))
(DEFUN PROFILER-ON () (DEFUN PROFILER-ON ()
(push (get-internal-run-time) *profiler-stack*)) (push (get-internal-run-time) *profiler-stack*))
@ -527,12 +531,12 @@ MAKE-INSTANCE.
(DEFUN PROFILER-OFF (mrph) (DEFUN PROFILER-OFF (mrph)
(declare (type morphism mrph)) (declare (type morphism mrph))
(let ((time-spent (let ((time-spent
(- (get-internal-run-time) (pop *profiler-stack*)))) (- (get-internal-run-time) (pop *profiler-stack*))))
(declare (integer time-spent)) (declare (integer time-spent))
(mapl #'(lambda (mark) (mapl #'(lambda (mark)
(declare (cons mark)) (declare (cons mark))
(incf (car mark) time-spent)) (incf (car mark) time-spent))
*profiler-stack*) *profiler-stack*)
(incf (wrtm mrph) time-spent))) (incf (wrtm mrph) time-spent)))
|# |#
@ -544,35 +548,35 @@ MAKE-INSTANCE.
(type gnrt gnrt)) (type gnrt gnrt))
(the cmbn (the cmbn
(progn (progn
;; (profiler-on) ;; (profiler-on)
(when (and *future-display* (when (and *future-display*
(> (get-internal-run-time) *future-display*)) (> (get-internal-run-time) *future-display*))
(format t "~%GNRT-? (format t "~%GNRT-?
~3T~A ORGN = ~A ~3T~A ORGN = ~A
~3TDEGR = ~D ~3TDEGR = ~D
~3TGNRT = ~A" ~3TGNRT = ~A"
mrph (orgn mrph) degr gnrt) mrph (orgn mrph) degr gnrt)
(setf *future-display* (+ (get-internal-run-time) *time-interval*))) (setf *future-display* (+ (get-internal-run-time) *time-interval*)))
(with-slots (sorc (mdegr degr) intr strt ?-clnm) mrph (with-slots (sorc (mdegr degr) intr strt ?-clnm) mrph
(declare (declare
(type chain-complex sorc) (type chain-complex sorc)
(fixnum mdegr ?-clnm) (fixnum mdegr ?-clnm)
(type intr-mrph intr) (type intr-mrph intr)
(type strt strt)) (type strt strt))
(with-slots ((scmpr cmpr)) sorc (with-slots ((scmpr cmpr)) sorc
(declare (type cmprf scmpr)) (declare (type cmprf scmpr))
(control (slot-value (slot-value mrph 'trgt) 'cmpr) (control (slot-value (slot-value mrph 'trgt) 'cmpr)
(progn (progn
(incf ?-clnm) (incf ?-clnm)
(prog1 (prog1
(ecase strt (ecase strt
(:gnrt (:gnrt
(mrph-gnrt scmpr intr (mrph-gnrt scmpr intr
degr gnrt (svref (rslts mrph) degr))) degr gnrt (svref (rslts mrph) degr)))
(:cmbn (:cmbn
(funcall intr (term-cmbn degr 1 gnrt)))) (funcall intr (term-cmbn degr 1 gnrt))))
;; (profiler-off mrph) ;; (profiler-off mrph)
)))))))) ))))))))
(DEFUN CMBN-? (mrph cmbn) (DEFUN CMBN-? (mrph cmbn)
@ -581,35 +585,35 @@ MAKE-INSTANCE.
(type cmbn cmbn)) (type cmbn cmbn))
(the cmbn (the cmbn
(progn (progn
;; (profiler-on) ;; (profiler-on)
(when (and *future-display* (when (and *future-display*
(> (get-internal-run-time) *future-display*)) (> (get-internal-run-time) *future-display*))
(format t "~%CMBN-? (format t "~%CMBN-?
~3T~A ORGN = ~A ~3T~A ORGN = ~A
~3TCMBN = ~A" ~3TCMBN = ~A"
mrph (orgn mrph) cmbn) mrph (orgn mrph) cmbn)
(setf *future-display* (+ (get-internal-run-time) *time-interval*))) (setf *future-display* (+ (get-internal-run-time) *time-interval*)))
(with-slots (sorc trgt degr intr strt ???-clnm) mrph (with-slots (sorc trgt degr intr strt ???-clnm) mrph
(declare (declare
(type chain-complex sorc trgt) (type chain-complex sorc trgt)
(fixnum degr ???-clnm) (fixnum degr ???-clnm)
(type intr-mrph intr) (type intr-mrph intr)
(type strt strt)) (type strt strt))
(with-slots ((scmpr cmpr)) sorc (with-slots ((scmpr cmpr)) sorc
(declare (type cmprf scmpr)) (declare (type cmprf scmpr))
(with-slots ((tcmpr cmpr)) trgt (with-slots ((tcmpr cmpr)) trgt
(declare (type cmprf tcmpr)) (declare (type cmprf tcmpr))
(control tcmpr (control tcmpr
(progn (progn
(controln scmpr cmbn) (controln scmpr cmbn)
(incf ???-clnm) (incf ???-clnm)
(when (eq strt :cmbn) (when (eq strt :cmbn)
(return-from cmbn-? (funcall intr cmbn))) (return-from cmbn-? (funcall intr cmbn)))
(prog1 (prog1
(if (cmbn-zero-p cmbn) (if (cmbn-zero-p cmbn)
(zero-cmbn (+ (cmbn-degr cmbn) degr)) (zero-cmbn (+ (cmbn-degr cmbn) degr))
(mrph-cmbn scmpr tcmpr intr (mrph-cmbn scmpr tcmpr intr
cmbn (svref (rslts mrph) cmbn (svref (rslts mrph)
(cmbn-degr cmbn)))) (cmbn-degr cmbn))))
;; (profiler-off mrph) ;; (profiler-off mrph)
))))))))) )))))))))

510
src/cl-space-efhm.lisp
View File

@ -7,9 +7,9 @@
(provide "cl-space-efhm") (provide "cl-space-efhm")
(DEFUN CS-HAT-U-U (smgr (DEFUN CS-HAT-U-U (smgr
&aux (bar (bar smgr)) &aux (bar (bar smgr))
(cl-space (classifying-space smgr)) (cl-space (classifying-space smgr))
(clsp-tnsr-smgr (tnsr-prdc cl-space smgr))) (clsp-tnsr-smgr (tnsr-prdc cl-space smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex bar clsp-tnsr-smgr) (type chain-complex bar clsp-tnsr-smgr)
@ -22,108 +22,108 @@
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(let ((aprd (aprd smgr))) (let ((aprd (aprd smgr)))
(flet ((rslt (degr tnpr) (flet ((rslt (degr tnpr)
(declare (declare
(fixnum degr) (fixnum degr)
(type tnpr tnpr)) (type tnpr tnpr))
(with-tnpr (with-tnpr
(degr1 tnpr1 degr2 abar2) tnpr (degr1 tnpr1 degr2 abar2) tnpr
(when (zerop degr2) (when (zerop degr2)
(return-from rslt (zero-cmbn (1- degr)))) (return-from rslt (zero-cmbn (1- degr))))
(with-tnpr (with-tnpr
(degr11 gbar11 degr12 gmsm12) tnpr1 (degr11 gbar11 degr12 gmsm12) tnpr1
(let ((sign (-1-expt-n degr1)) (let ((sign (-1-expt-n degr1))
(brgn21 (first (abar-list abar2))) (brgn21 (first (abar-list abar2)))
(bar22 (make-abar :list (rest (abar-list abar2))))) (bar22 (make-abar :list (rest (abar-list abar2)))))
(declare (declare
(fixnum sign) (fixnum sign)
(type brgn brgn21) (type brgn brgn21)
(type abar bar22)) (type abar bar22))
(with-brgn (with-brgn
(degr21 gmsm21) brgn21 (degr21 gmsm21) brgn21
(let ((degr22 (- degr2 degr21))) (let ((degr22 (- degr2 degr21)))
(declare (fixnum degr22)) (declare (fixnum degr22))
(decf degr21) ;; = dmns(gmsm21) (decf degr21) ;; = dmns(gmsm21)
(let ((aprd (gnrt-? aprd (+ degr12 degr21) (let ((aprd (gnrt-? aprd (+ degr12 degr21)
(tnpr degr12 gmsm12 (tnpr degr12 gmsm12
degr21 gmsm21)))) degr21 gmsm21))))
(declare (type cmbn aprd)) (declare (type cmbn aprd))
(with-cmbn (with-cmbn
(degr12+21 list) aprd (degr12+21 list) aprd
(make-cmbn (make-cmbn
:degr (1- degr) :degr (1- degr)
:list :list
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc gmsm) term (cffc gmsm) term
(term (* sign cffc) (term (* sign cffc)
(tnpr (+ degr1 degr21) (tnpr (+ degr1 degr21)
(tnpr degr11 gbar11 (tnpr degr11 gbar11
degr12+21 gmsm) degr12+21 gmsm)
degr22 bar22)))) degr22 bar22))))
list))))))))))) list)))))))))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
(DEFUN CS-HAT-RIGHT-PERTURBATION (smgr (DEFUN CS-HAT-RIGHT-PERTURBATION (smgr
&aux (hat-u-u (cs-hat-u-u smgr))) &aux (hat-u-u (cs-hat-u-u smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-u-u)) (type chain-complex hat-u-u))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc hat-u-u :sorc hat-u-u
:trgt hat-u-u :trgt hat-u-u
:degr -1 :degr -1
:intr (cs-hat-right-perturbation-intr smgr) :intr (cs-hat-right-perturbation-intr smgr)
:strt :gnrt :strt :gnrt
:orgn `(cs-hat-right-perturbation ,smgr)))) :orgn `(cs-hat-right-perturbation ,smgr))))
(DEFUN CS-HAT-U-T (smgr (DEFUN CS-HAT-U-T (smgr
&aux (hat-u-u (cs-hat-u-u smgr)) &aux (hat-u-u (cs-hat-u-u smgr))
(hat-right-perturbation (hat-right-perturbation
(cs-hat-right-perturbation smgr))) (cs-hat-right-perturbation smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-u-u) (type chain-complex hat-u-u)
(type morphism hat-right-perturbation)) (type morphism hat-right-perturbation))
(the chain-complex (the chain-complex
(progn (progn
(setf (slot-value hat-right-perturbation 'sorc) hat-u-u (setf (slot-value hat-right-perturbation 'sorc) hat-u-u
(slot-value hat-right-perturbation 'trgt) hat-u-u) (slot-value hat-right-perturbation 'trgt) hat-u-u)
;; cf lp-space-efhm.lisp ;; cf lp-space-efhm.lisp
(add hat-u-u hat-right-perturbation)))) (add hat-u-u hat-right-perturbation))))
(DEFUN CS-HAT-LEFT-PERTURBATION (smgr (DEFUN CS-HAT-LEFT-PERTURBATION (smgr
&aux (fibration (smgr-fibration smgr)) &aux (fibration (smgr-fibration smgr))
(bar (bar smgr)) (bar (bar smgr))
(hat-u-t (cs-hat-u-t smgr))) (hat-u-t (cs-hat-u-t smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type fibration fibration) (type fibration fibration)
(type chain-complex bar hat-u-t)) (type chain-complex bar hat-u-t))
(the morphism (the morphism
(multiple-value-bind (brown bottom-perturbation) (multiple-value-bind (brown bottom-perturbation)
(brown-reduction fibration) (brown-reduction fibration)
(declare (declare
(ignore brown) (ignore brown)
(type morphism bottom-perturbation)) (type morphism bottom-perturbation))
(let ((rslt (tnsr-prdc bottom-perturbation (idnt-mrph bar)))) (let ((rslt (tnsr-prdc bottom-perturbation (idnt-mrph bar))))
(declare (type morphism rslt)) (declare (type morphism rslt))
(setf (slot-value rslt 'sorc) hat-u-t (setf (slot-value rslt 'sorc) hat-u-t
(slot-value rslt 'trgt) hat-u-t) (slot-value rslt 'trgt) hat-u-t)
rslt)))) rslt))))
(DEFUN CS-HAT-T-U (smgr (DEFUN CS-HAT-T-U (smgr
&aux (bar (bar smgr)) &aux (bar (bar smgr))
(fibration (smgr-fibration smgr)) (fibration (smgr-fibration smgr))
(brown (brown-reduction fibration)) (brown (brown-reduction fibration))
(twisted-tnsr-prdc (bcc brown)) (twisted-tnsr-prdc (bcc brown))
(hat-u-u (cs-hat-u-u smgr))) (hat-u-u (cs-hat-u-u smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex bar twisted-tnsr-prdc hat-u-u) (type chain-complex bar twisted-tnsr-prdc hat-u-u)
@ -131,15 +131,15 @@
(type reduction brown)) (type reduction brown))
(the chain-complex (the chain-complex
(let ((rslt (tnsr-prdc twisted-tnsr-prdc bar))) (let ((rslt (tnsr-prdc twisted-tnsr-prdc bar)))
(declare (type chain-complex rslt)) (declare (type chain-complex rslt))
(setf (slot-value rslt 'grmd) hat-u-u) (setf (slot-value rslt 'grmd) hat-u-u)
rslt))) rslt)))
(DEFUN CS-LEFT-HMEQ-HAT (smgr (DEFUN CS-LEFT-HMEQ-HAT (smgr
&aux (hat-t-u (cs-hat-t-u smgr)) &aux (hat-t-u (cs-hat-t-u smgr))
(hat-right-perturbation (hat-right-perturbation
(cs-hat-right-perturbation smgr))) (cs-hat-right-perturbation smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-t-u) (type chain-complex hat-t-u)
@ -152,248 +152,248 @@
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(make-cmbn (make-cmbn
:degr degr :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr) term (cffc tnpr) term
(term cffc (gnrt1 (gnrt1 tnpr))))) (term cffc (gnrt1 (gnrt1 tnpr)))))
(member-if (member-if
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr) term (cffc tnpr) term
(declare (ignore cffc)) (declare (ignore cffc))
(with-tnpr (with-tnpr
(degr1 tnpr1 degr2 abar2) tnpr (degr1 tnpr1 degr2 abar2) tnpr
(declare (ignore degr1 abar2)) (declare (ignore degr1 abar2))
(and (zerop degr2) (zerop (degr2 tnpr1)))))) (and (zerop degr2) (zerop (degr2 tnpr1))))))
list)))))) list))))))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (smgr (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (smgr
&aux (hat-u-t (cs-hat-u-t smgr)) &aux (hat-u-t (cs-hat-u-t smgr))
(classifying-space (classifying-space smgr))) (classifying-space (classifying-space smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-u-t) (type chain-complex hat-u-t)
(type simplicial-set classifying-space)) (type simplicial-set classifying-space))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc hat-u-t :sorc hat-u-t
:trgt classifying-space :trgt classifying-space
:degr 0 :degr 0
:intr #'cs-pre-left-hmeq-left-reduction-intr-f :intr #'cs-pre-left-hmeq-left-reduction-intr-f
:strt :cmbn :strt :cmbn
:orgn `(cs-pre-left-hmeq-left-reduction-f ,smgr)))) :orgn `(cs-pre-left-hmeq-left-reduction-f ,smgr))))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-G (idnt) (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-G (idnt)
(declare (type gmsm idnt)) (declare (type gmsm idnt))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(make-cmbn (make-cmbn
:degr degr :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc gbar) term (cffc gbar) term
(term cffc (term cffc
(tnpr degr (tnpr degr
(tnpr degr gbar 0 idnt) (tnpr degr gbar 0 idnt)
0 +null-abar+)))) 0 +null-abar+))))
list)))))) list))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-G (smgr (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-G (smgr
&aux (hat-u-t (cs-hat-u-t smgr)) &aux (hat-u-t (cs-hat-u-t smgr))
(classifying-space (classifying-space
(classifying-space smgr))) (classifying-space smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-u-t) (type chain-complex hat-u-t)
(type simplicial-set classifying-space)) (type simplicial-set classifying-space))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc classifying-space :sorc classifying-space
:trgt hat-u-t :trgt hat-u-t
:degr 0 :degr 0
:intr (cs-pre-left-hmeq-left-reduction-intr-g (bspn smgr)) :intr (cs-pre-left-hmeq-left-reduction-intr-g (bspn smgr))
:strt :cmbn :strt :cmbn
:orgn `(cs-pre-left-hmeq-left-reduction-g ,smgr)))) :orgn `(cs-pre-left-hmeq-left-reduction-g ,smgr))))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-H (cmpr idnt) (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-H (cmpr idnt)
(declare (type gmsm idnt)) (declare (type gmsm idnt))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(do ((rslt (zero-cmbn (1+ degr))) (do ((rslt (zero-cmbn (1+ degr)))
(mark list (cdr mark))) (mark list (cdr mark)))
((endp mark) rslt) ((endp mark) rslt)
(declare (declare
(type cmbn rslt) (type cmbn rslt)
(list mark)) (list mark))
(let ((term (car mark))) (let ((term (car mark)))
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr) term (cffc tnpr) term
(with-tnpr (with-tnpr
(degr1 tnpr1 degr2 abar2) tnpr (degr1 tnpr1 degr2 abar2) tnpr
(declare (ignore degr1)) (declare (ignore degr1))
(with-tnpr (with-tnpr
(degr11 gbar11 degr12 gmsm12) tnpr1 (degr11 gbar11 degr12 gmsm12) tnpr1
(unless (zerop degr12) (unless (zerop degr12)
(dstr-add-term-to-cmbn (dstr-add-term-to-cmbn
cmpr cmpr
(if (evenp degr11) cffc (- cffc)) (if (evenp degr11) cffc (- cffc))
(tnpr degr11 (tnpr degr11
(tnpr degr11 gbar11 0 idnt) (tnpr degr11 gbar11 0 idnt)
(+ 1 degr12 degr2) (+ 1 degr12 degr2)
(make-abar (make-abar
:list :list
(cons (brgn (1+ degr12) (cons (brgn (1+ degr12)
gmsm12) gmsm12)
(abar-list abar2)))) (abar-list abar2))))
rslt))))))))))) rslt)))))))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (smgr (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (smgr
&aux (hat-u-t (cs-hat-u-t smgr))) &aux (hat-u-t (cs-hat-u-t smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-u-t)) (type chain-complex hat-u-t))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc hat-u-t :sorc hat-u-t
:trgt hat-u-t :trgt hat-u-t
:degr +1 :degr +1
:intr (cs-pre-left-hmeq-left-reduction-intr-h (cmpr hat-u-t) :intr (cs-pre-left-hmeq-left-reduction-intr-h (cmpr hat-u-t)
(bspn smgr)) (bspn smgr))
:strt :cmbn :strt :cmbn
:orgn `(cs-pre-left-hmeq-left-reduction-h ,smgr)))) :orgn `(cs-pre-left-hmeq-left-reduction-h ,smgr))))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION (smgr) (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION (smgr)
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(the reduction (the reduction
(build-rdct (build-rdct
:f (cs-pre-left-hmeq-left-reduction-f smgr) :f (cs-pre-left-hmeq-left-reduction-f smgr)
:g (cs-pre-left-hmeq-left-reduction-g smgr) :g (cs-pre-left-hmeq-left-reduction-g smgr)
:h (cs-pre-left-hmeq-left-reduction-h smgr) :h (cs-pre-left-hmeq-left-reduction-h smgr)
:orgn `(cs-pre-left-hmeq-left-reduction ,smgr)))) :orgn `(cs-pre-left-hmeq-left-reduction ,smgr))))
(DEFUN CS-LEFT-HMEQ-LEFT-REDUCTION (smgr (DEFUN CS-LEFT-HMEQ-LEFT-REDUCTION (smgr
&aux (pre-left-hmeq-left-reduction &aux (pre-left-hmeq-left-reduction
(cs-pre-left-hmeq-left-reduction (cs-pre-left-hmeq-left-reduction
smgr)) smgr))
(hat-left-perturbation (hat-left-perturbation
(cs-hat-left-perturbation smgr))) (cs-hat-left-perturbation smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type reduction pre-left-hmeq-left-reduction) (type reduction pre-left-hmeq-left-reduction)
(type morphism hat-left-perturbation)) (type morphism hat-left-perturbation))
(the reduction (the reduction
(progn (progn
(dstr-change-sorc-trgt hat-left-perturbation (dstr-change-sorc-trgt hat-left-perturbation
:new-sorc (tcc pre-left-hmeq-left-reduction) :new-sorc (tcc pre-left-hmeq-left-reduction)
:new-trgt (tcc pre-left-hmeq-left-reduction)) :new-trgt (tcc pre-left-hmeq-left-reduction))
(let ((rslt (special-bpl-2 pre-left-hmeq-left-reduction (let ((rslt (special-bpl-2 pre-left-hmeq-left-reduction
hat-left-perturbation))) hat-left-perturbation)))
(declare (type reduction rslt)) (declare (type reduction rslt))
(with-slots (tcc f g h) rslt (with-slots (tcc f g h) rslt
(setf tcc (cs-left-hmeq-hat smgr) (setf tcc (cs-left-hmeq-hat smgr)
(slot-value f 'sorc) tcc (slot-value f 'sorc) tcc
(slot-value g 'trgt) tcc (slot-value g 'trgt) tcc
(slot-value h 'sorc) tcc (slot-value h 'sorc) tcc
(slot-value h 'trgt) tcc)) (slot-value h 'trgt) tcc))
rslt)))) rslt))))
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F (cmbn) (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((rslt +empty-list+)) (let ((rslt +empty-list+))
(declare (list rslt)) (declare (list rslt))
(do ((mark list (cdr mark))) (do ((mark list (cdr mark)))
((endp mark)) ((endp mark))
(declare (list mark)) (declare (list mark))
(with--term (cffc tnpr) mark (with--term (cffc tnpr) mark
(with-tnpr (degr1 nil nil abar2) tnpr (with-tnpr (degr1 nil nil abar2) tnpr
(if (zerop degr1) (if (zerop degr1)
(push (term cffc abar2) rslt) (push (term cffc abar2) rslt)
(return))))) (return)))))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (nreverse rslt)))))) :list (nreverse rslt))))))
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (smgr (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (smgr
&aux (hat-t-u (cs-hat-t-u smgr)) &aux (hat-t-u (cs-hat-t-u smgr))
(bar (bar smgr))) (bar (bar smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-t-u bar)) (type chain-complex hat-t-u bar))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc hat-t-u :trgt bar :degr 0 :sorc hat-t-u :trgt bar :degr 0
:intr #'cs-pre-left-hmeq-right-reduction-intr-f :intr #'cs-pre-left-hmeq-right-reduction-intr-f
:strt :cmbn :strt :cmbn
:orgn `(cs-pre-left-hmeq-right-reduction-f ,smgr)))) :orgn `(cs-pre-left-hmeq-right-reduction-f ,smgr))))
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (idnt) (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (idnt)
(declare (type gmsm idnt)) (declare (type gmsm idnt))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(let ((bsgn (tnpr 0 +null-gbar+ 0 idnt))) (let ((bsgn (tnpr 0 +null-gbar+ 0 idnt)))
(declare (type tnpr bsgn)) (declare (type tnpr bsgn))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc abar) term (cffc abar) term
(term cffc (term cffc
(tnpr 0 bsgn (tnpr 0 bsgn
degr abar)))) degr abar))))
list))))))) list)))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (smgr (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (smgr
&aux (hat-t-u (cs-hat-t-u smgr)) &aux (hat-t-u (cs-hat-t-u smgr))
(bar (bar smgr)) (bar (bar smgr))
(idnt (bspn smgr))) (idnt (bspn smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-t-u bar) (type chain-complex hat-t-u bar)
(type gmsm idnt)) (type gmsm idnt))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc bar :trgt hat-t-u :degr 0 :sorc bar :trgt hat-t-u :degr 0
:intr (cs-pre-left-hmeq-right-reduction-intr-g idnt) :intr (cs-pre-left-hmeq-right-reduction-intr-g idnt)
:strt :cmbn :strt :cmbn
:orgn `(cs-pre-left-hmeq-right-reduction-g ,smgr)))) :orgn `(cs-pre-left-hmeq-right-reduction-g ,smgr))))
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (smgr (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (smgr
&aux (bar (bar smgr)) &aux (bar (bar smgr))
(tnpr-contraction (tnpr-contraction
(smgr-tnpr-contraction smgr))) (smgr-tnpr-contraction smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex bar) (type chain-complex bar)
@ -405,42 +405,42 @@
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(the reduction (the reduction
(build-rdct (build-rdct
:f (cs-pre-left-hmeq-right-reduction-f smgr) :f (cs-pre-left-hmeq-right-reduction-f smgr)
:g (cs-pre-left-hmeq-right-reduction-g smgr) :g (cs-pre-left-hmeq-right-reduction-g smgr)
:h (cs-pre-left-hmeq-right-reduction-h smgr) :h (cs-pre-left-hmeq-right-reduction-h smgr)
:orgn `(cs-pre-left-hmeq-right-reduction ,smgr)))) :orgn `(cs-pre-left-hmeq-right-reduction ,smgr))))
(DEFUN CS-LEFT-HMEQ-RIGHT-REDUCTION (smgr (DEFUN CS-LEFT-HMEQ-RIGHT-REDUCTION (smgr
&aux (pre-reduction &aux (pre-reduction
(cs-pre-left-hmeq-right-reduction (cs-pre-left-hmeq-right-reduction
smgr)) smgr))
(perturbation (perturbation
(cs-hat-right-perturbation smgr))) (cs-hat-right-perturbation smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type reduction pre-reduction) (type reduction pre-reduction)
(type morphism perturbation)) (type morphism perturbation))
(the reduction (the reduction
(progn (progn
(setf (slot-value perturbation 'sorc) (tcc pre-reduction) (setf (slot-value perturbation 'sorc) (tcc pre-reduction)
(slot-value perturbation 'trgt) (tcc pre-reduction)) (slot-value perturbation 'trgt) (tcc pre-reduction))
(special-bpl-2 pre-reduction perturbation)))) (special-bpl-2 pre-reduction perturbation))))
(DEFUN CS-LEFT-HMEQ (smgr) (DEFUN CS-LEFT-HMEQ (smgr)
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(the homotopy-equivalence (the homotopy-equivalence
(build-hmeq (build-hmeq
:lrdct (cs-left-hmeq-left-reduction smgr) :lrdct (cs-left-hmeq-left-reduction smgr)
:rrdct (cs-left-hmeq-right-reduction smgr) :rrdct (cs-left-hmeq-right-reduction smgr)
:orgn `(cs-left-hmeq ,smgr)))) :orgn `(cs-left-hmeq ,smgr))))
(DEFUN CLASSIFYING-SPACE-EFHM (smgr) (DEFUN CLASSIFYING-SPACE-EFHM (smgr)
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(let ((left-hmeq (cs-left-hmeq smgr)) (let ((left-hmeq (cs-left-hmeq smgr))
(right-hmeq (bar (efhm smgr)))) (right-hmeq (bar (efhm smgr))))
(declare (type homotopy-equivalence left-hmeq right-hmeq)) (declare (type homotopy-equivalence left-hmeq right-hmeq))
(cmps left-hmeq right-hmeq))) (cmps left-hmeq right-hmeq)))

166
src/classes.lisp
View File

@ -45,7 +45,7 @@ internal representation of combinations.
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (typep object 'fixnum) (and (typep object 'fixnum)
(/= 0 object)))) (/= 0 object))))
(DEFTYPE CFFC () (DEFTYPE CFFC ()
"------------------------------------------------------------------[type-doc] "------------------------------------------------------------------[type-doc]
@ -90,8 +90,8 @@ A derived type to represent comparison functions.
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(typep (car object) 'cffc) (typep (car object) 'cffc)
(typep (cdr object) 'gnrt)))) (typep (cdr object) 'gnrt))))
(DEFTYPE TERM () (DEFTYPE TERM ()
"------------------------------------------------------------------[type-doc] "------------------------------------------------------------------[type-doc]
@ -110,7 +110,7 @@ and whose CDR is of type GNRT.
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (listp object) (and (listp object)
(every #'term-p object)))) (every #'term-p object))))
(DEFTYPE ICMBN () '(satisfies icmbn-p)) (DEFTYPE ICMBN () '(satisfies icmbn-p))
@ -141,8 +141,8 @@ the symbol :LOCALLY-EFFECTIVE.
#+allegro #+allegro
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(setf redefinition-warnings-saved (setf redefinition-warnings-saved
excl::*redefinition-warnings* excl::*redefinition-warnings*
*redefinition-warnings* nil)) *redefinition-warnings* nil))
(DEFCLASS CHAIN-COMPLEX () (DEFCLASS CHAIN-COMPLEX ()
((cmpr :type cmprf :initarg :cmpr :reader cmpr1) ((cmpr :type cmprf :initarg :cmpr :reader cmpr1)
@ -178,16 +178,25 @@ Intances of this class represent chain complexes. The class has 8 slots:
4. DFFR, the differential morphism, an instance of the class MORPHISM. Its 4. DFFR, the differential morphism, an instance of the class MORPHISM. Its
reader function is DFFR1. reader function is DFFR1.
5. GRMD, ??? Its reader function is GRMD. 5. GRMD, refers to some chain-complex considered as a reference for the
underlying graded module structure. Sometimes, it is better to check two
chain-complexes have the same underlying graded module. Typically if C1 is
a chain-complex and C2 is obtained from C1 by perturbing the differential,
then (eq (grmd C1) (grmd C2)) should return T. Its reader function is GRMD.
6. EFHM, ??? Its reader function is EFHM. 6. EFHM, if the effective homology of the chain complex has already been
computed, then this slot points to the HOMOTOPY-EQUIVALENCE which IS the
effective homology of this object. Otherwise the slot is unbound. Its
reader function is EFHM.
7. IDNM, an integer, a system generated identifier for this object. Its reader 7. IDNM, an integer, a system generated identifier for this object. Its reader
function is IDNM. function is IDNM.
8. ORGN, a list containg a comment indicating the origin of the object. The 8. ORGN, a list which is the copy of a Lisp statement, in principle the
should be unique (per session), since it is used in the implementation for statement which was at the origin of the creation of this Kenzo object.
caching purposes. Its reader function is ORGN. A caching process, using this slot, prevents the creation of multiple
copies of the same mathematical object, which is important for efficiency.
It is used also for debugging and analyzing the program.
-----------------------------------------------------------------------------")) -----------------------------------------------------------------------------"))
@ -218,8 +227,8 @@ A derived type, which represents the mapping strategy of morphisms.
(?-clnm :type fixnum :initform 0 :accessor ?-clnm) (?-clnm :type fixnum :initform 0 :accessor ?-clnm)
;; ReSuLTS ;; ReSuLTS
(rslts :type simple-vector (rslts :type simple-vector
;; (vector (vector result)) ;; (vector (vector result))
:reader rslts) :reader rslts)
;; IDentification NuMber ;; IDentification NuMber
(idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm) (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
;; ORiGiN ;; ORiGiN
@ -240,11 +249,22 @@ degree -1. The class has 10 slots:
3. DEGR, an integer, the degree of the morphism. Its reader function is DEGR. 3. DEGR, an integer, the degree of the morphism. Its reader function is DEGR.
4. INTR, a Lisp function implementing the morphism, taking account of the 4. INTR, a Lisp INTeRnal function implementing the morphism, taking account
strategy STRT. Its reader function is INTR. of the strategy STRT. Its reader function is INTR.
5. STRT, a symbol, one of :GNRT or :CMBN. Its reader function is STRT. 5. STRT, a symbol, one of :GNRT or :CMBN. Its reader function is STRT.
If this slot is :GNRT, the implementation of INTR is a function:
(function (degr gnrt) cmbn)
and for any call of this function, the result is stored in the slot
RSLTS to avoid later a possibly long recalculation for the same
argument.
If this slot is :CMBN, the implementation of INTR is a function:
(function (cmbn) cmbn)
and the RSLTS slot is not used. Think for example to an identity or
null function, where storing a result is wasted time.
6. ???-CLNM, an integer updated by the system for internal statistics. Its 6. ???-CLNM, an integer updated by the system for internal statistics. Its
reader function is ???-CLNM. reader function is ???-CLNM.
@ -257,9 +277,11 @@ degree -1. The class has 10 slots:
9. IDNM, an integer, a system-generated identifier for this object. Its reader 9. IDNM, an integer, a system-generated identifier for this object. Its reader
function is IDNM. function is IDNM.
10. ORGN, a list containg a comment indicating the origin of the object. The 10. ORGN, a list which is the copy of a Lisp statement, in principle the
should be unique (per session), since it is used in the implementation for statement which was at the origin of the creation of this Kenzo object.
caching purposes. Its reader function is ORGN. A caching process, using this slot, prevents the creation of multiple
copies of the same mathematical object, which is important for efficiency.
It is used also for debugging and analyzing the program.
-----------------------------------------------------------------------------")) -----------------------------------------------------------------------------"))
@ -308,21 +330,23 @@ The class has 7 slots:
2. BCC, an object of type CHAIN-COMPLEX, the bottom chain complex C. Its reader 2. BCC, an object of type CHAIN-COMPLEX, the bottom chain complex C. Its reader
function is BCC1. function is BCC1.
3. F, an object of type MORPHISM representing the morphism f. Its reader 3. F, an object of type MORPHISM representing the chain morphism f. Its reader
function is F1. function is F1.
4. G, an object of type MORPHISM representing the morphism g. Its reader 4. G, an object of type MORPHISM representing the chain morphism g. Its reader
function is G1. function is G1.
5. H, an object of type MORPHISM representing the morphism h. Its reader 5. H, an object of type MORPHISM representing the morphism of graded modules h.
function is H1. Its reader function is H1.
9. IDNM, an integer, a system-generated identifier for this object. Its reader 6. IDNM, an integer, a system-generated identifier for this object. Its reader
function is IDNM. function is IDNM.
10. ORGN, a list containg a comment indicating the origin of the object. The 7. ORGN, a list which is the copy of a Lisp statement, in principle the
should be unique (per session), since it is used in the implementation for statement which was at the origin of the creation of this Kenzo object.
caching purposes. Its reader function is ORGN. A caching process, using this slot, prevents the creation of multiple
copies of the same mathematical object, which is important for efficiency.
It is used also for debugging and analyzing the program.
-----------------------------------------------------------------------------")) -----------------------------------------------------------------------------"))
@ -352,12 +376,19 @@ The class has 7 slots:
;; IDentification NuMber ;; IDentification NuMber
(idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm) (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
;; ORiGiN ;; ORiGiN
(orgn :type list :initarg :orgn :reader orgn))) (orgn :type list :initarg :orgn :reader orgn))
(:documentation
"----------------------------------------------------------------[class-doc]
HOMOTOPY-EQUIVALENCE
A homotopy-equivalence is essentially a pair of respective reductions from an
intermediate chain complex TCC to the LBCC (left bottom) and RBCC (rigth
bottom) chain complexes. It is an equivalence between LBCC and RBCC.
-----------------------------------------------------------------------------"))
#+allegro #+allegro
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(setf excl::*redefinition-warnings* (setf excl::*redefinition-warnings*
redefinition-warnings-saved)) redefinition-warnings-saved))
;;; ;;;
;;; HOMOLOGY-GROUPS ;;; HOMOLOGY-GROUPS
@ -365,9 +396,31 @@ The class has 7 slots:
(DEFSTRUCT (matrice (:conc-name nil)) (DEFSTRUCT (matrice (:conc-name nil))
"------------------------------------------------------------------[type-doc]
MATRICE
Slots: (leftcol uplig)
A MATRICE is made of two vectors LEFTCOL and UPLIG. LEFTCOL is a
vector of size m+1 if m is the number of rows of the matrix, UPLIG is
a vector of size n+1 if n is the number of columns.
Every element of LEFTCOL and UPLIG is a T-MAT with the value NIL
indicating it is a fake term.
------------------------------------------------------------------------------"
leftcol uplig) leftcol uplig)
(DEFSTRUCT (t-mat (:conc-name nil)) (DEFSTRUCT (t-mat (:conc-name nil))
"------------------------------------------------------------------[type-doc]
T-MAT
Slots: (val ilig icol left up)
A T-MAT (= Terme de Matrice) has five components:
VAL = A value, an integer, in principle a non-null integer.
ILIG = the line (row is better) index of this term
ICOL = the column index of this term
LEFT = a pointer to the next term on the left on the same line,
or to a fake term, an element of LEFTCOL of the matrice.
UP = a pointer to the next term above on the same column,
or to a fake term, an element of UPLIG of the matrice.
------------------------------------------------------------------------------"
val ilig icol left up) val ilig icol left up)
@ -379,11 +432,26 @@ The class has 7 slots:
(conx (:type '(member 0 1))) (conx (:type '(member 0 1)))
(icon (:type 'gnrt))) (icon (:type 'gnrt)))
;; Given a morphism f : C1 -> C0 between two chain complexes,
;; the cone of f is a chain complex made of C0 as such,
;; C1 suspended.
;; The differential of the C0 component is unchanged.
;; If x is an element of C1, then d_cone(x) = -dx + fx
;; with dx computed as in the original C1.
;; A CONE generator is an conx 0 (resp. 1) and
;; and an icon (= internal cone generator) being a
;; generator of C0 (resp. C1).
(DEFSTRUCT (BICN (:conc-name nil) (:print-function bicn-print)) (DEFSTRUCT (BICN (:conc-name nil) (:print-function bicn-print))
(bcnx (:type '(member :bcnb :bcnc :bcnd))) (bcnx (:type '(member :bcnb :bcnc :bcnd)))
(ibicn (:type 'gnrt))) (ibicn (:type 'gnrt)))
;; Analogous with two morphisms f: B -> C and g: D -> C.
;; Intended to become the central part of a zigzag :
;; A <- B -> C <- D -> E
;; The key structure to compose two equivalences:
;; A <- B -> C and C <- D -> E
;;; ;;;
;;; TENSOR-PRODUCTS ;;; TENSOR-PRODUCTS
@ -412,8 +480,8 @@ The class has 7 slots:
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(typep (car object) 'fixnum) ;; degree *in* the cobar (typep (car object) 'fixnum) ;; degree *in* the cobar
(typep (cdr object) 'gnrt)))) (typep (cdr object) 'gnrt))))
(DEFTYPE CBGN () '(satisfies cbgn-p)) (DEFTYPE CBGN () '(satisfies cbgn-p))
@ -422,7 +490,7 @@ The class has 7 slots:
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (listp object) (and (listp object)
(every #'cbgn-p object)))) (every #'cbgn-p object))))
(DEFTYPE IALLP () '(satisfies iallp-p)) (DEFTYPE IALLP () '(satisfies iallp-p))
@ -454,8 +522,8 @@ The class has 7 slots:
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(typep (car object) 'fixnum) ;; degree *in* the bar (typep (car object) 'fixnum) ;; degree *in* the bar
(typep (cdr object) 'gnrt)))) (typep (cdr object) 'gnrt))))
(DEFTYPE BRGN () '(satisfies brgn-p)) (DEFTYPE BRGN () '(satisfies brgn-p))
@ -464,7 +532,7 @@ The class has 7 slots:
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (listp object) (and (listp object)
(every #'brgn-p object)))) (every #'brgn-p object))))
(DEFTYPE IABAR () '(satisfies iabar-p)) (DEFTYPE IABAR () '(satisfies iabar-p))
@ -476,8 +544,8 @@ The class has 7 slots:
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(eq :abar (car object)) (eq :abar (car object))
(typep (cdr object) 'iabar)))) (typep (cdr object) 'iabar))))
(DEFTYPE ABAR () '(satisfies abar-p)) (DEFTYPE ABAR () '(satisfies abar-p))
|# |#
@ -508,8 +576,8 @@ The class has 7 slots:
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(typep (car object) 'dgop) (typep (car object) 'dgop)
(typep (cdr object) 'gmsm)))) (typep (cdr object) 'gmsm))))
(DEFTYPE IABSM () '(satisfies iabsm-p)) (DEFTYPE IABSM () '(satisfies iabsm-p))
@ -555,8 +623,8 @@ The class has 7 slots:
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(eq :delt (car object)) (eq :delt (car object))
(typep (cdr object) 'dgop)))) (typep (cdr object) 'dgop))))
(DEFTYPE SOFT-DLOP () '(satisfies soft-dlop-p)) (DEFTYPE SOFT-DLOP () '(satisfies soft-dlop-p))
@ -589,7 +657,7 @@ The class has 7 slots:
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (typep object 'simplicial-mrph) (and (typep object 'simplicial-mrph)
(= -1 (degr object))))) (= -1 (degr object)))))
(DEFTYPE FIBRATION () (DEFTYPE FIBRATION ()
'(satisfies fibration-p)) '(satisfies fibration-p))
@ -610,7 +678,7 @@ The class has 7 slots:
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(typep object '(and fixnum (typep object '(and fixnum
(not (eql 0)))))) (not (eql 0))))))
(DEFTYPE EXPN () '(satisfies expn-p)) (DEFTYPE EXPN () '(satisfies expn-p))
@ -619,8 +687,8 @@ The class has 7 slots:
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(typep (car object) 'gmsm) (typep (car object) 'gmsm)
(typep (cdr object) 'expn)))) (typep (cdr object) 'expn))))
(DEFTYPE POWR () '(satisfies powr-p)) (DEFTYPE POWR () '(satisfies powr-p))
@ -629,8 +697,8 @@ The class has 7 slots:
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(typep (car object) 'dgop) (typep (car object) 'dgop)
(typep (cdr object) 'powr)))) (typep (cdr object) 'powr))))
(DEFTYPE APOWR () '(satisfies apowr-p)) (DEFTYPE APOWR () '(satisfies apowr-p))
@ -639,7 +707,7 @@ The class has 7 slots:
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (listp object) (and (listp object)
(every #'apowr-p object)))) (every #'apowr-p object))))
(DEFTYPE ILOOP () '(satisfies iloop-p)) (DEFTYPE ILOOP () '(satisfies iloop-p))
@ -650,7 +718,7 @@ The class has 7 slots:
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :common-lisp) nil)) (setf (ext:package-lock :common-lisp) nil))
#+sbcl(eval-when (:compile-toplevel :load-toplevel :execute) #+sbcl(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:unlock-package :common-lisp)) (sb-ext:unlock-package :common-lisp))
(DEFSTRUCT (LOOP (:print-function loop-print)) (DEFSTRUCT (LOOP (:print-function loop-print))
(list (:type 'iloop))) (list (:type 'iloop)))
@ -661,7 +729,7 @@ The class has 7 slots:
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :common-lisp) t)) (setf (ext:package-lock :common-lisp) t))
#+sbcl(eval-when (:compile-toplevel :load-toplevel :execute) #+sbcl(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:lock-package :common-lisp)) (sb-ext:lock-package :common-lisp))
#+ccl #+ccl
(DEFMETHOD make-load-form ((l loop) &optional env) (DEFMETHOD make-load-form ((l loop) &optional env)

4
src/combinations.lisp
View File

@ -137,8 +137,8 @@ CMBN
Args: (degr &rest rest) Args: (degr &rest rest)
Returns a combination of degree DEGR from a sum of terms provided as a sequence Returns a combination of degree DEGR from a sum of terms provided as a sequence
CF1 GNRT1 CF2 GNRT2 ... CFn GNRTn of coefficient / generator pairs in REST. CF1 GNRT1 CF2 GNRT2 ... CFn GNRTn of coefficient / generator pairs in REST.
REST can be of arbitrary even length and can be empty, in which case the REST can be of arbitrary length including NIL, in which case the combination
combination is an instance of the null combination of degree DEGR. is an instance of the null combination of degree DEGR.
------------------------------------------------------------------------------" ------------------------------------------------------------------------------"
(the cmbn (the cmbn
(make-cmbn :degr degr (make-cmbn :degr degr

405
src/effective-homology.lisp
View File

@ -16,9 +16,9 @@
(DEFMETHOD PRINT-OBJECT ((rdct reduction) stream) (DEFMETHOD PRINT-OBJECT ((rdct reduction) stream)
(the reduction (the reduction
(progn (progn
(format stream "[K~D Reduction K~D => K~D]" (format stream "[K~D Reduction K~D => K~D]"
(idnm rdct) (idnm (tcc rdct)) (idnm (bcc rdct))) (idnm rdct) (idnm (tcc rdct)) (idnm (bcc rdct)))
rdct))) rdct)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -45,16 +45,21 @@ Args: (&key f g h orgn)
Returns an instance of the class REDUCTION. The keyword arguments are as Returns an instance of the class REDUCTION. The keyword arguments are as
follows: follows:
:F F, an object of type morphism representing the morphism f of a reduction :F F, an object of type MORPHISM representing the chain morphism f of a
reduction
:G G, an object of type morphism representing the morphism g of a reduction :G G, an object of type MORPHISM representing the chain morphism g of a
reduction
:H H, an object of type morphism representing the morphism h of a reduction :H H, an object of type MORPHISM representing the morphism of graded modules h
of a reduction
:ORGN ORGN, a list containing a relevant and carefully chosen comment about :ORGN ORGN, a list which is the copy of a Lisp statement, in principle the
the origin of the chain complex. This comment should be unique statement which was at the origin of the creation of this Kenzo
for a Kenzo session (between calls of CAT-INIT), as it is used object. A caching process, using this slot, prevents the creation
for caching purposes. of multiple copies of the same mathematical object, which is
important for efficiency. It is used also for debugging and
analyzing the program.
Use this function instead of creating instances via the standard constructor Use this function instead of creating instances via the standard constructor
MAKE-INSTANCE. MAKE-INSTANCE.
@ -62,38 +67,38 @@ MAKE-INSTANCE.
(the reduction (the reduction
(progn (progn
(unless orgn (unless orgn
(setf orgn `(build-rdct ,f ,g ,h))) (setf orgn `(build-rdct ,f ,g ,h)))
(let ((already (find orgn *rdct-list* :test #'equal :key #'orgn))) (let ((already (find orgn *rdct-list* :test #'equal :key #'orgn)))
(declare (type (or reduction null) already)) (declare (type (or reduction null) already))
(when already (when already
(return-from build-rdct already))) (return-from build-rdct already)))
(with-slots ((fsorc sorc) (ftrgt trgt) (fdegr degr)) f (with-slots ((fsorc sorc) (ftrgt trgt) (fdegr degr)) f
(declare (declare
(type chain-complex fsorc ftrgt) (type chain-complex fsorc ftrgt)
(fixnum fdegr)) (fixnum fdegr))
(with-slots ((gsorc sorc) (gtrgt trgt) (gdegr degr)) g (with-slots ((gsorc sorc) (gtrgt trgt) (gdegr degr)) g
(declare (declare
(type chain-complex gsorc gtrgt) (type chain-complex gsorc gtrgt)
(fixnum gdegr)) (fixnum gdegr))
(with-slots ((hsorc sorc) (htrgt trgt) (hdegr degr)) h (with-slots ((hsorc sorc) (htrgt trgt) (hdegr degr)) h
(declare (declare
(type chain-complex hsorc htrgt) (type chain-complex hsorc htrgt)
(fixnum hdegr)) (fixnum hdegr))
(unless (and (eq gsorc ftrgt) (unless (and (eq gsorc ftrgt)
(eq fsorc gtrgt) (eq fsorc gtrgt)
(eq hsorc fsorc) (eq hsorc fsorc)
(eq htrgt fsorc) (eq htrgt fsorc)
(zerop fdegr) (zerop fdegr)
(zerop gdegr) (zerop gdegr)
(= +1 hdegr)) (= +1 hdegr))
(error "In BUILD-RDCT, the data are non coherent.")) (error "In BUILD-RDCT, the data are non coherent."))
(let ((rdct (make-instance 'reduction (let ((rdct (make-instance 'reduction
:tcc fsorc :bcc ftrgt :tcc fsorc :bcc ftrgt
:f f :g g :h h :f f :g g :h h
:orgn orgn))) :orgn orgn)))
(declare (type reduction rdct)) (declare (type reduction rdct))
(push rdct *rdct-list*) (push rdct *rdct-list*)
rdct))))))) rdct)))))))
(DEFUN TRIVIAL-RDCT (chcm) (DEFUN TRIVIAL-RDCT (chcm)
@ -139,27 +144,27 @@ See also: ZERO-MRPH, IDNT-MRPH.
(the homotopy-equivalence (the homotopy-equivalence
(progn (progn
(with-slots ((lf f) (lg g) (lh h) (ltcc tcc) (lbcc bcc)) lrdct (with-slots ((lf f) (lg g) (lh h) (ltcc tcc) (lbcc bcc)) lrdct
(declare (declare
(type morphism lf lg lh) (type morphism lf lg lh)
(type chain-complex ltcc lbcc)) (type chain-complex ltcc lbcc))
(with-slots ((rf f) (rg g) (rh h) (rtcc tcc) (rbcc bcc)) rrdct (with-slots ((rf f) (rg g) (rh h) (rtcc tcc) (rbcc bcc)) rrdct
(declare (declare
(type morphism rf rg rh) (type morphism rf rg rh)
(type chain-complex rtcc rbcc)) (type chain-complex rtcc rbcc))
(unless (eq ltcc rtcc) (unless (eq ltcc rtcc)
(error "In BUILD-HMEQ (version from rdct), the tcc's are not the same.")) (error "In BUILD-HMEQ (version from rdct), the tcc's are not the same."))
(unless orgn (unless orgn
(setf orgn `(build-hmeq ,lrdct ,rrdct))) (setf orgn `(build-hmeq ,lrdct ,rrdct)))
(let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn))) (let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn)))
(declare (type (or homotopy-equivalence null) already)) (declare (type (or homotopy-equivalence null) already))
(when already (when already
(return-from build-hmeq already))) (return-from build-hmeq already)))
(let ((hmeq (make-instance 'homotopy-equivalence (let ((hmeq (make-instance 'homotopy-equivalence
:lbcc lbcc :tcc ltcc :rbcc rbcc :lbcc lbcc :tcc ltcc :rbcc rbcc
:lf lf :lg lg :lh lh :lf lf :lg lg :lh lh
:rf rf :rg rg :rh rh :rf rf :rg rg :rh rh
:lrdct lrdct :rrdct rrdct :lrdct lrdct :rrdct rrdct
:orgn orgn))) :orgn orgn)))
(declare (type homotopy-equivalence hmeq)) (declare (type homotopy-equivalence hmeq))
(push hmeq *hmeq-list*) (push hmeq *hmeq-list*)
hmeq)))))) hmeq))))))
@ -170,10 +175,10 @@ See also: ZERO-MRPH, IDNT-MRPH.
(DEFMETHOD PRINT-OBJECT ((hmeq homotopy-equivalence) stream) (DEFMETHOD PRINT-OBJECT ((hmeq homotopy-equivalence) stream)
(the homotopy-equivalence (the homotopy-equivalence
(progn (progn
(format stream "[K~D Homotopy-Equivalence K~D <= K~D => K~D]" (format stream "[K~D Homotopy-Equivalence K~D <= K~D => K~D]"
(idnm hmeq) (idnm hmeq)
(idnm (lbcc hmeq)) (idnm (tcc hmeq)) (idnm (rbcc hmeq))) (idnm (lbcc hmeq)) (idnm (tcc hmeq)) (idnm (rbcc hmeq)))
hmeq))) hmeq)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -191,16 +196,16 @@ See also: ZERO-MRPH, IDNT-MRPH.
(the homotopy-equivalence (the homotopy-equivalence
(progn (progn
(unless orgn (unless orgn
(setf orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh))) (setf orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh)))
(let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn))) (let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn)))
(declare (type (or null homotopy-equivalence) already)) (declare (type (or null homotopy-equivalence) already))
(when already (when already
(return-from build-hmeq already))) (return-from build-hmeq already)))
(build-hmeq (build-hmeq
:lrdct (build-rdct :f lf :g lg :h lh :lrdct (build-rdct :f lf :g lg :h lh
:orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh lrdct)) :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh lrdct))
:rrdct (build-rdct :f rf :g rg :h rh :rrdct (build-rdct :f rf :g rg :h rh
:orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh rrdct)) :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh rrdct))
:orgn orgn)))) :orgn orgn))))
(DEFUN TRIVIAL-HMEQ (chcm) (DEFUN TRIVIAL-HMEQ (chcm)
@ -253,21 +258,21 @@ according to these formulas:
(type chain-complex bcc tcc) (type chain-complex bcc tcc)
(type morphism f g h)) (type morphism f g h))
(setf *tdd* (cmps tcc tcc) (setf *tdd* (cmps tcc tcc)
*bdd* (cmps bcc bcc) *bdd* (cmps bcc bcc)
*df-fd* (sbtr *df-fd* (sbtr
(cmps bcc f) (cmps bcc f)
(cmps f tcc)) (cmps f tcc))
*dg-gd* (sbtr *dg-gd* (sbtr
(cmps tcc g) (cmps tcc g)
(cmps g bcc)) (cmps g bcc))
*id-fg* (sbtr (idnt-mrph bcc) (cmps f g)) *id-fg* (sbtr (idnt-mrph bcc) (cmps f g))
*id-gf-dh-hd* (i-sbtr (idnt-mrph tcc) *id-gf-dh-hd* (i-sbtr (idnt-mrph tcc)
(cmps g f) (cmps g f)
(cmps tcc h) (cmps tcc h)
(cmps h tcc)) (cmps h tcc))
*hh* (cmps h h) *hh* (cmps h h)
*fh* (cmps f h) *fh* (cmps f h)
*hg* (cmps h g))) *hg* (cmps h g)))
(done)) (done))
@ -289,13 +294,13 @@ the <Enter> key.
(declare (type symbol cmbn)) (declare (type symbol cmbn))
(format t "~%~A => ~A" cmbn (eval cmbn))) (format t "~%~A => ~A" cmbn (eval cmbn)))
(dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd* (dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd*
*hh* *fh* *hg*)) *hh* *fh* *hg*))
(declare (type symbol phi)) (declare (type symbol phi))
(format t "~%Checking ~A = 0" phi) (format t "~%Checking ~A = 0" phi)
(format t "~%Result: ") (format t "~%Result: ")
(princ (cmbn-? (eval phi) (princ (cmbn-? (eval phi)
(if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*)) (if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*))
*bc* *tc*))) *bc* *tc*)))
(read-line)) (read-line))
(done)) (done))
@ -314,13 +319,13 @@ coherent, the result of each mapping is a null combination.
(declare (type symbol cmbn)) (declare (type symbol cmbn))
(format t "~%~A => ~A" cmbn (eval cmbn))) (format t "~%~A => ~A" cmbn (eval cmbn)))
(dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd* (dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd*
*hh* *fh* *hg*)) *hh* *fh* *hg*))
(declare (type symbol phi)) (declare (type symbol phi))
(format t "~%Checking ~A = 0" phi) (format t "~%Checking ~A = 0" phi)
(format t "~%Result: ") (format t "~%Result: ")
(princ (cmbn-? (eval phi) (princ (cmbn-? (eval phi)
(if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*)) (if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*))
*bc* *tc*)))) *bc* *tc*))))
(done)) (done))
@ -363,47 +368,47 @@ coherent, the result of each mapping is a null combination.
(type morphism top-perturbation)) (type morphism top-perturbation))
(the (values reduction morphism) (the (values reduction morphism)
(with-slots ((old-tcc tcc) (old-bcc bcc) (with-slots ((old-tcc tcc) (old-bcc bcc)
(old-f f) (old-g g) (old-h h)) reduction (old-f f) (old-g g) (old-h h)) reduction
(declare (declare
(type chain-complex old-tcc old-bcc) (type chain-complex old-tcc old-bcc)
(type morphism old-f old-g old-h)) (type morphism old-f old-g old-h))
(when (eq (first (orgn top-perturbation)) 'zero-mrph) (when (eq (first (orgn top-perturbation)) 'zero-mrph)
(return-from basic-perturbation-lemma (return-from basic-perturbation-lemma
(values reduction (zero-mrph old-bcc)))) (values reduction (zero-mrph old-bcc))))
(when (eq (first (orgn (h reduction))) 'zero-mrph) (when (eq (first (orgn (h reduction))) 'zero-mrph)
(return-from basic-perturbation-lemma (return-from basic-perturbation-lemma
(values (values
(trivial-rdct (add old-tcc top-perturbation)) (trivial-rdct (add old-tcc top-perturbation))
(i-cmps old-f top-perturbation old-g)))) (i-cmps old-f top-perturbation old-g))))
(let* ((sigma (bpl-*-sigma old-h top-perturbation)) (let* ((sigma (bpl-*-sigma old-h top-perturbation))
(new-f (cmps old-f (new-f (cmps old-f
(sbtr (idnt-mrph old-tcc) (sbtr (idnt-mrph old-tcc)
(i-cmps (i-cmps
top-perturbation top-perturbation
sigma sigma
old-h)))) old-h))))
(new-g (cmps sigma old-g)) (new-g (cmps sigma old-g))
(new-h (cmps sigma old-h)) (new-h (cmps sigma old-h))
(bottom-perturbation (i-cmps (bottom-perturbation (i-cmps
old-f old-f
top-perturbation top-perturbation
new-g)) new-g))
(new-tcc (add old-tcc top-perturbation)) (new-tcc (add old-tcc top-perturbation))
(new-bcc (add old-bcc bottom-perturbation))) (new-bcc (add old-bcc bottom-perturbation)))
(declare (declare
(type chain-complex new-tcc new-bcc) (type chain-complex new-tcc new-bcc)
(type morphism sigma new-f new-g new-h bottom-perturbation)) (type morphism sigma new-f new-g new-h bottom-perturbation))
(setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc (setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc
:new-trgt new-bcc) :new-trgt new-bcc)
new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc
:new-trgt new-tcc) :new-trgt new-tcc)
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
:new-trgt new-tcc)) :new-trgt new-tcc))
(values (values
(build-rdct :f new-f :g new-g :h new-h (build-rdct :f new-f :g new-g :h new-h
:orgn `(basic-perturbation-lemma ,reduction :orgn `(basic-perturbation-lemma ,reduction
,top-perturbation)) ,top-perturbation))
bottom-perturbation))))) bottom-perturbation)))))
(DEFUN EASY-PERTURBATION-LEMMA (reduction bottom-perturbation) (DEFUN EASY-PERTURBATION-LEMMA (reduction bottom-perturbation)
(declare (declare
@ -411,32 +416,32 @@ coherent, the result of each mapping is a null combination.
(type morphism bottom-perturbation)) (type morphism bottom-perturbation))
(the (values reduction morphism) (the (values reduction morphism)
(with-slots ((old-tcc tcc) (old-bcc bcc) (with-slots ((old-tcc tcc) (old-bcc bcc)
(old-f f) (old-g g) (old-h h)) reduction (old-f f) (old-g g) (old-h h)) reduction
(declare (declare
(type chain-complex old-tcc old-bcc) (type chain-complex old-tcc old-bcc)
(type morphism old-f old-g old-h)) (type morphism old-f old-g old-h))
(when (eq 'zero-mrph (first (orgn bottom-perturbation))) (when (eq 'zero-mrph (first (orgn bottom-perturbation)))
(return-from easy-perturbation-lemma (return-from easy-perturbation-lemma
(values reduction (zero-mrph old-tcc)))) (values reduction (zero-mrph old-tcc))))
(when (eq 'trivial-rdct (first (orgn reduction))) (when (eq 'trivial-rdct (first (orgn reduction)))
(return-from easy-perturbation-lemma (return-from easy-perturbation-lemma
(trivial-rdct (add (bcc reduction) bottom-perturbation)))) (trivial-rdct (add (bcc reduction) bottom-perturbation))))
(let ((top-perturbation (i-cmps old-g bottom-perturbation old-f))) (let ((top-perturbation (i-cmps old-g bottom-perturbation old-f)))
(declare (type morphism top-perturbation)) (declare (type morphism top-perturbation))
(let ((new-bcc (add old-bcc bottom-perturbation)) (let ((new-bcc (add old-bcc bottom-perturbation))
(new-tcc (add old-tcc top-perturbation))) (new-tcc (add old-tcc top-perturbation)))
(declare (type chain-complex new-bcc new-tcc)) (declare (type chain-complex new-bcc new-tcc))
(values (values
(build-rdct (build-rdct
:f (dstr-change-sorc-trgt old-f :new-sorc new-tcc :f (dstr-change-sorc-trgt old-f :new-sorc new-tcc
:new-trgt new-bcc) :new-trgt new-bcc)
:g (dstr-change-sorc-trgt old-g :new-sorc new-bcc :g (dstr-change-sorc-trgt old-g :new-sorc new-bcc
:new-trgt new-tcc) :new-trgt new-tcc)
:h (dstr-change-sorc-trgt old-h :new-sorc new-tcc :h (dstr-change-sorc-trgt old-h :new-sorc new-tcc
:new-trgt new-tcc) :new-trgt new-tcc)
:orgn `(easy-perturbation-lemma ,reduction :orgn `(easy-perturbation-lemma ,reduction
,bottom-perturbation)) ,bottom-perturbation))
top-perturbation)))))) top-perturbation))))))
(DEFUN SPECIAL-BPL (reduction top-perturbation) (DEFUN SPECIAL-BPL (reduction top-perturbation)
(declare (declare
@ -446,28 +451,28 @@ coherent, the result of each mapping is a null combination.
(return-from special-bpl reduction)) (return-from special-bpl reduction))
(the reduction (the reduction
(with-slots ((old-tcc tcc) (old-bcc bcc) (with-slots ((old-tcc tcc) (old-bcc bcc)
(old-f f) (old-g g) (old-h h)) reduction (old-f f) (old-g g) (old-h h)) reduction
(declare (declare
(type chain-complex old-tcc old-bcc) (type chain-complex old-tcc old-bcc)
(type morphism old-f old-g old-h)) (type morphism old-f old-g old-h))
(let* ((sigma (bpl-*-sigma old-h top-perturbation)) (let* ((sigma (bpl-*-sigma old-h top-perturbation))
(new-f (cmps old-f (new-f (cmps old-f
(sbtr (idnt-mrph old-tcc) (sbtr (idnt-mrph old-tcc)
(i-cmps (i-cmps
top-perturbation top-perturbation
sigma sigma
old-h)))) old-h))))
(new-h (cmps sigma old-h)) (new-h (cmps sigma old-h))
(new-tcc (add old-tcc top-perturbation))) (new-tcc (add old-tcc top-perturbation)))
(declare (declare
(type chain-complex new-tcc) (type chain-complex new-tcc)
(type morphism sigma new-f new-h)) (type morphism sigma new-f new-h))
(setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc) (setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc)
old-g (dstr-change-sorc-trgt old-g :new-trgt new-tcc) old-g (dstr-change-sorc-trgt old-g :new-trgt new-tcc)
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
:new-trgt new-tcc)) :new-trgt new-tcc))
(build-rdct :f new-f :g old-g :h new-h (build-rdct :f new-f :g old-g :h new-h
:orgn `(special-bpl ,reduction ,top-perturbation)))))) :orgn `(special-bpl ,reduction ,top-perturbation))))))
(DEFUN SPECIAL-BPL-2 (reduction top-perturbation) (DEFUN SPECIAL-BPL-2 (reduction top-perturbation)
(declare (declare
@ -475,69 +480,69 @@ coherent, the result of each mapping is a null combination.
(type morphism top-perturbation)) (type morphism top-perturbation))
(the reduction (the reduction
(with-slots ((old-tcc tcc) (old-bcc bcc) (with-slots ((old-tcc tcc) (old-bcc bcc)
(old-f f) (old-g g) (old-h h)) reduction (old-f f) (old-g g) (old-h h)) reduction
(declare (declare
(type chain-complex old-tcc old-bcc) (type chain-complex old-tcc old-bcc)
(type morphism old-f old-g old-h)) (type morphism old-f old-g old-h))
(when (eq (first (orgn top-perturbation)) 'zero-mrph) (when (eq (first (orgn top-perturbation)) 'zero-mrph)
(return-from special-bpl-2 (return-from special-bpl-2
(values reduction (zero-mrph old-bcc)))) (values reduction (zero-mrph old-bcc))))
(when (eq (first (orgn (h reduction))) 'zero-mrph) (when (eq (first (orgn (h reduction))) 'zero-mrph)
(return-from special-bpl-2 (return-from special-bpl-2
(values (values
(trivial-rdct (add old-tcc top-perturbation)) (trivial-rdct (add old-tcc top-perturbation))
(i-cmps old-f top-perturbation old-g)))) (i-cmps old-f top-perturbation old-g))))
(let* ((sigma (bpl-*-sigma old-h top-perturbation)) (let* ((sigma (bpl-*-sigma old-h top-perturbation))
(new-g (cmps sigma old-g)) (new-g (cmps sigma old-g))
(new-h (cmps sigma old-h)) (new-h (cmps sigma old-h))
(new-tcc (add old-tcc top-perturbation))) (new-tcc (add old-tcc top-perturbation)))
(declare (declare
(type chain-complex new-tcc) (type chain-complex new-tcc)
(type morphism sigma new-g new-h)) (type morphism sigma new-g new-h))
(setf old-f (dstr-change-sorc-trgt old-f :new-sorc new-tcc) (setf old-f (dstr-change-sorc-trgt old-f :new-sorc new-tcc)
new-g (dstr-change-sorc-trgt new-g :new-trgt new-tcc) new-g (dstr-change-sorc-trgt new-g :new-trgt new-tcc)
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc
:new-trgt new-tcc)) :new-trgt new-tcc))
(values (values
(build-rdct :f old-f :g new-g :h new-h (build-rdct :f old-f :g new-g :h new-h
:orgn `(special-bpl-2 ,reduction ,top-perturbation))))))) :orgn `(special-bpl-2 ,reduction ,top-perturbation)))))))
(DEFUN BPL-*-sigma (homotopy perturbation) (DEFUN BPL-*-sigma (homotopy perturbation)
(declare (type morphism homotopy perturbation)) (declare (type morphism homotopy perturbation))
(the morphism (the morphism
(let ((cmpr (cmpr (sorc perturbation))) (let ((cmpr (cmpr (sorc perturbation)))
(h-delta (cmps homotopy perturbation))) (h-delta (cmps homotopy perturbation)))
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type morphism h-delta)) (type morphism h-delta))
(flet (flet
((sigma-* (degr gnrt) ((sigma-* (degr gnrt)
(declare (declare
(fixnum degr) (fixnum degr)
(type gnrt gnrt)) (type gnrt gnrt))
(do ((rslt (zero-cmbn degr) (2cmbn-add cmpr rslt iterated)) (do ((rslt (zero-cmbn degr) (2cmbn-add cmpr rslt iterated))
(iterated (term-cmbn degr 1 gnrt) (iterated (term-cmbn degr 1 gnrt)
(cmbn-opps (cmbn-? h-delta iterated)))) (cmbn-opps (cmbn-? h-delta iterated))))
((cmbn-zero-p iterated) rslt) ((cmbn-zero-p iterated) rslt)
(declare (type cmbn rslt iterated))))) (declare (type cmbn rslt iterated)))))
(build-mrph (build-mrph
:sorc (sorc homotopy) :trgt (sorc homotopy) :degr 0 :sorc (sorc homotopy) :trgt (sorc homotopy) :degr 0
:intr #'sigma-* :intr #'sigma-*
:strt :gnrt :strt :gnrt
:orgn `(bpl-*-sigma ,homotopy ,perturbation)))))) :orgn `(bpl-*-sigma ,homotopy ,perturbation))))))
(DEFMETHOD ADD ((hmeq homotopy-equivalence) (lb-perturbation morphism) (DEFMETHOD ADD ((hmeq homotopy-equivalence) (lb-perturbation morphism)
&optional dummy) &optional dummy)
(declare (ignore dummy)) (declare (ignore dummy))
(the homotopy-equivalence (the homotopy-equivalence
(with-slots (lrdct rrdct) hmeq (with-slots (lrdct rrdct) hmeq
(declare (type reduction lrdct rrdct)) (declare (type reduction lrdct rrdct))
(multiple-value-bind (new-lrdct top-perturbation) (multiple-value-bind (new-lrdct top-perturbation)
(add lrdct lb-perturbation) (add lrdct lb-perturbation)
(declare (declare
(type reduction new-lrdct) (type reduction new-lrdct)
(type morphism lb-perturbation)) (type morphism lb-perturbation))
(build-hmeq (build-hmeq
:lrdct new-lrdct :lrdct new-lrdct
:rrdct (add rrdct top-perturbation) :rrdct (add rrdct top-perturbation)
:orgn `(add ,hmeq ,lb-perturbation)))))) :orgn `(add ,hmeq ,lb-perturbation))))))

448
src/lp-space-efhm.lisp
View File

@ -7,9 +7,9 @@
(PROVIDE "lp-space-efhm") (PROVIDE "lp-space-efhm")
(DEFUN LS-HAT-U-U (space (DEFUN LS-HAT-U-U (space
&aux (cobar (cobar space)) &aux (cobar (cobar space))
(loop-space (loop-space space)) (loop-space (loop-space space))
(spac-tnsr-lpsp (tnsr-prdc space loop-space))) (spac-tnsr-lpsp (tnsr-prdc space loop-space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex cobar spac-tnsr-lpsp) (type chain-complex cobar spac-tnsr-lpsp)
@ -22,38 +22,38 @@
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(let ((cprd (dgnl space))) (let ((cprd (dgnl space)))
(flet ((rslt (degr tnpr) (flet ((rslt (degr tnpr)
(declare (declare
(fixnum degr) (fixnum degr)
(type tnpr tnpr)) (type tnpr tnpr))
(with-tnpr (with-tnpr
(degr1 allp1 nil tnpr2) tnpr (degr1 allp1 nil tnpr2) tnpr
(with-tnpr (with-tnpr
(degr21 gmsm21 degr22 loop22) tnpr2 (degr21 gmsm21 degr22 loop22) tnpr2
(let ((cprd (cmbn-list (gnrt-? cprd degr21 gmsm21)))) (let ((cprd (cmbn-list (gnrt-? cprd degr21 gmsm21))))
(declare (list cprd)) (declare (list cprd))
(setf cprd (rest cprd)) ;;; because \bar{A} (setf cprd (rest cprd)) ;;; because \bar{A}
(make-cmbn (make-cmbn
:degr (1- degr) :degr (1- degr)
:list :list
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr21) term (cffc tnpr21) term
(with-tnpr (with-tnpr
(degr211 gmsm211 degr212 gmsm212) tnpr21 (degr211 gmsm211 degr212 gmsm212) tnpr21
(decf degr211) (decf degr211)
(term cffc (tnpr (+ degr1 degr211) (term cffc (tnpr (+ degr1 degr211)
(make-allp (make-allp
:list :list
(append (append
(allp-list allp1) (allp-list allp1)
(list (cbgn degr211 (list (cbgn degr211
gmsm211)))) gmsm211))))
(+ degr212 degr22) (+ degr212 degr22)
(tnpr degr212 gmsm212 (tnpr degr212 gmsm212
degr22 loop22)))))) degr22 loop22))))))
cprd))))))) cprd)))))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
@ -62,17 +62,17 @@
(the morphism (the morphism
(let ((ls-hat-u-u (ls-hat-u-u space))) (let ((ls-hat-u-u (ls-hat-u-u space)))
(build-mrph (build-mrph
:sorc ls-hat-u-u :sorc ls-hat-u-u
:trgt ls-hat-u-u :trgt ls-hat-u-u
:degr -1 :degr -1
:intr (ls-hat-left-perturbation-intr space) :intr (ls-hat-left-perturbation-intr space)
:strt :gnrt :strt :gnrt
:orgn `(ls-hat-left-perturbation ,space))))) :orgn `(ls-hat-left-perturbation ,space)))))
(DEFUN LS-HAT-T-U (space (DEFUN LS-HAT-T-U (space
&aux (ls-hat-u-u (ls-hat-u-u space)) &aux (ls-hat-u-u (ls-hat-u-u space))
(ls-hat-left-perturbation (ls-hat-left-perturbation
(ls-hat-left-perturbation space))) (ls-hat-left-perturbation space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-u-u) (type chain-complex ls-hat-u-u)
@ -87,27 +87,27 @@
(DEFUN LS-HAT-RIGHT-PERTURBATION (space (DEFUN LS-HAT-RIGHT-PERTURBATION (space
&aux (cobar (cobar space)) &aux (cobar (cobar space))
(ls-hat-t-u (ls-hat-t-u space))) (ls-hat-t-u (ls-hat-t-u space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex cobar ls-hat-t-u)) (type chain-complex cobar ls-hat-t-u))
(the morphism (the morphism
(multiple-value-bind (szczarba bottom-perturbation) (multiple-value-bind (szczarba bottom-perturbation)
(szczarba space) (szczarba space)
(declare (declare
(ignore szczarba) (ignore szczarba)
(type morphism bottom-perturbation)) (type morphism bottom-perturbation))
(let ((rslt (tnsr-prdc (idnt-mrph cobar) bottom-perturbation))) (let ((rslt (tnsr-prdc (idnt-mrph cobar) bottom-perturbation)))
(declare (type morphism rslt)) (declare (type morphism rslt))
(setf (slot-value rslt 'sorc) ls-hat-t-u (setf (slot-value rslt 'sorc) ls-hat-t-u
(slot-value rslt 'trgt) ls-hat-t-u) (slot-value rslt 'trgt) ls-hat-t-u)
rslt)))) rslt))))
(DEFUN LS-HAT-U-T (space (DEFUN LS-HAT-U-T (space
&aux (cobar (cobar space)) &aux (cobar (cobar space))
(twisted-tnsr-prdc (twisted-tnsr-prdc space)) (twisted-tnsr-prdc (twisted-tnsr-prdc space))
(ls-hat-u-u (ls-hat-u-u space))) (ls-hat-u-u (ls-hat-u-u space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex cobar twisted-tnsr-prdc ls-hat-u-u)) (type chain-complex cobar twisted-tnsr-prdc ls-hat-u-u))
@ -119,10 +119,10 @@
(DEFUN LS-LEFT-HMEQ-HAT (space (DEFUN LS-LEFT-HMEQ-HAT (space
&aux &aux
(ls-hat-u-t (ls-hat-u-t space)) (ls-hat-u-t (ls-hat-u-t space))
(ls-hat-left-perturbation (ls-hat-left-perturbation
(ls-hat-left-perturbation space))) (ls-hat-left-perturbation space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-u-t) (type chain-complex ls-hat-u-t)
@ -137,75 +137,75 @@
(let ((rslt +empty-list+)) (let ((rslt +empty-list+))
(declare (list rslt)) (declare (list rslt))
(dolist (term (cmbn-list cmbn)) (dolist (term (cmbn-list cmbn))
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr) term (cffc tnpr) term
(with-tnpr (degr1 nil nil tnpr2) tnpr (with-tnpr (degr1 nil nil tnpr2) tnpr
(if (zerop degr1) (if (zerop degr1)
(with-tnpr (with-tnpr
(degr21 nil nil loop22) tnpr2 (degr21 nil nil loop22) tnpr2
(if (zerop degr21) (if (zerop degr21)
(push (term cffc loop22) rslt) (push (term cffc loop22) rslt)
(return))) (return)))
(return))))) (return)))))
(make-cmbn :degr (cmbn-degr cmbn) (make-cmbn :degr (cmbn-degr cmbn)
:list (nreverse rslt))))) :list (nreverse rslt)))))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (space (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (space
&aux (ls-hat-t-u (ls-hat-t-u space)) &aux (ls-hat-t-u (ls-hat-t-u space))
(loop-space (loop-space space))) (loop-space (loop-space space)))
(declare (declare
(type simplicial-set space loop-space) (type simplicial-set space loop-space)
(type chain-complex ls-hat-t-u)) (type chain-complex ls-hat-t-u))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc ls-hat-t-u :sorc ls-hat-t-u
:trgt loop-space :trgt loop-space
:degr 0 :degr 0
:intr #'ls-pre-left-hmeq-left-reduction-intr-f :intr #'ls-pre-left-hmeq-left-reduction-intr-f
:strt :cmbn :strt :cmbn
:orgn `(ls-pre-left-hmeq-left-reduction-f ,space)))) :orgn `(ls-pre-left-hmeq-left-reduction-f ,space))))
(DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G-INTR (bspn) (DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G-INTR (bspn)
(declare (type gmsm bspn)) (declare (type gmsm bspn))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc loop) term (cffc loop) term
(term cffc (term cffc
(tnpr (tnpr
0 +null-allp+ 0 +null-allp+
degr degr
(tnpr 0 bspn degr (tnpr 0 bspn degr
loop))))) loop)))))
list)))))) list))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G (space (DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G (space
&aux (bspn (bspn space)) &aux (bspn (bspn space))
(ls-hat-t-u (ls-hat-t-u space)) (ls-hat-t-u (ls-hat-t-u space))
(loop-space (loop-space space))) (loop-space (loop-space space)))
(declare (declare
(type simplicial-set space loop-space) (type simplicial-set space loop-space)
(type gmsm bspn) (type gmsm bspn)
(type chain-complex ls-hat-t-u)) (type chain-complex ls-hat-t-u))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc loop-space :sorc loop-space
:trgt ls-hat-t-u :trgt ls-hat-t-u
:degr 0 :degr 0
:intr (ls-left-hmeq-left-reduction-g-intr bspn) :intr (ls-left-hmeq-left-reduction-g-intr bspn)
:strt :cmbn :strt :cmbn
:orgn `(ls-left-hmeq-left-reduction-g ,space)))) :orgn `(ls-left-hmeq-left-reduction-g ,space))))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H-INTR (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H-INTR
@ -219,88 +219,88 @@
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(let ((rslt (zero-cmbn (1+ degr)))) (let ((rslt (zero-cmbn (1+ degr))))
(declare (type cmbn rslt)) (declare (type cmbn rslt))
(dolist (term list) (dolist (term list)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr) term (cffc tnpr) term
(with-tnpr (with-tnpr
(degr1 allp1 degr2 tnpr2) tnpr (degr1 allp1 degr2 tnpr2) tnpr
(unless (zerop degr1) (unless (zerop degr1)
(with-tnpr (with-tnpr
(degr21 nil degr22 loop22) tnpr2 (degr21 nil degr22 loop22) tnpr2
(when (zerop degr21) (when (zerop degr21)
(setf allp1 (allp-list allp1)) ;;;+++ (setf allp1 (allp-list allp1)) ;;;+++
(let ((last-cbgn (car (last allp1)))) (let ((last-cbgn (car (last allp1))))
(declare (type cbgn last-cbgn)) (declare (type cbgn last-cbgn))
(with-cbgn (with-cbgn
(degrl gmsml) last-cbgn (degrl gmsml) last-cbgn
(dstr-add-term-to-cmbn (dstr-add-term-to-cmbn
cmpr cffc cmpr cffc
(tnpr (- degr1 degrl) (tnpr (- degr1 degrl)
(make-allp (make-allp
:list (butlast allp1)) :list (butlast allp1))
(+ degr2 degrl 1) (+ degr2 degrl 1)
(tnpr (1+ degrl) gmsml (tnpr (1+ degrl) gmsml
degr22 loop22)) degr22 loop22))
rslt))))))))) rslt)))))))))
rslt))))) rslt)))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (space (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (space
&aux (ls-hat-t-u (ls-hat-t-u space))) &aux (ls-hat-t-u (ls-hat-t-u space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-t-u)) (type chain-complex ls-hat-t-u))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc ls-hat-t-u :sorc ls-hat-t-u
:trgt ls-hat-t-u :trgt ls-hat-t-u
:degr +1 :degr +1
:intr (ls-pre-left-hmeq-left-reduction-h-intr space) :intr (ls-pre-left-hmeq-left-reduction-h-intr space)
:strt :cmbn :strt :cmbn
:orgn `(ls-pre-left-hmeq-left-reduction-h ,space)))) :orgn `(ls-pre-left-hmeq-left-reduction-h ,space))))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION (space) (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION (space)
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(the reduction (the reduction
(build-rdct (build-rdct
:f (ls-pre-left-hmeq-left-reduction-f space) :f (ls-pre-left-hmeq-left-reduction-f space)
:g (ls-left-hmeq-left-reduction-g space) :g (ls-left-hmeq-left-reduction-g space)
:h (ls-pre-left-hmeq-left-reduction-h space) :h (ls-pre-left-hmeq-left-reduction-h space)
:orgn `(ls-pre-left-hmeq-left-reduction ,space)))) :orgn `(ls-pre-left-hmeq-left-reduction ,space))))
(DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION (space (DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION (space
&aux (ls-pre-left-hmeq-left-reduction &aux (ls-pre-left-hmeq-left-reduction
(ls-pre-left-hmeq-left-reduction (ls-pre-left-hmeq-left-reduction
space)) space))
(ls-hat-right-perturbation (ls-hat-right-perturbation
(ls-hat-right-perturbation space))) (ls-hat-right-perturbation space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type reduction ls-pre-left-hmeq-left-reduction) (type reduction ls-pre-left-hmeq-left-reduction)
(type morphism ls-hat-right-perturbation)) (type morphism ls-hat-right-perturbation))
(the reduction (the reduction
(progn (progn
(dstr-change-sorc-trgt ls-hat-right-perturbation (dstr-change-sorc-trgt ls-hat-right-perturbation
:new-sorc (tcc ls-pre-left-hmeq-left-reduction) :new-sorc (tcc ls-pre-left-hmeq-left-reduction)
:new-trgt (tcc ls-pre-left-hmeq-left-reduction)) :new-trgt (tcc ls-pre-left-hmeq-left-reduction))
(let ((rslt (special-bpl ls-pre-left-hmeq-left-reduction (let ((rslt (special-bpl ls-pre-left-hmeq-left-reduction
ls-hat-right-perturbation))) ls-hat-right-perturbation)))
(declare (type reduction rslt)) (declare (type reduction rslt))
(with-slots (tcc f g h) rslt (with-slots (tcc f g h) rslt
(setf tcc (ls-left-hmeq-hat space) (setf tcc (ls-left-hmeq-hat space)
(slot-value f 'sorc) tcc (slot-value f 'sorc) tcc
(slot-value g 'trgt) tcc (slot-value g 'trgt) tcc
(slot-value h 'sorc) tcc (slot-value h 'sorc) tcc
(slot-value h 'trgt) tcc) (slot-value h 'trgt) tcc)
rslt))))) rslt)))))
;;; -[CLISP ;;; -[CLISP
@ -309,14 +309,14 @@
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((tail (member 0 list :test #'= :key #'cadddr))) (let ((tail (member 0 list :test #'= :key #'cadddr)))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc tnpr) term (with-term (cffc tnpr) term
(term cffc (gnrt1 tnpr)))) (term cffc (gnrt1 tnpr))))
tail)))))) tail))))))
|# |#
;;; LISP]- ;;; LISP]-
;;; +[CLISP ;;; +[CLISP
@ -324,74 +324,74 @@
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((tail (member 0 list (let ((tail (member 0 list
:key #'(lambda (term) :key #'(lambda (term)
(declare (type term term)) (declare (type term term))
(degr2 (gnrt term)))))) (degr2 (gnrt term))))))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc tnpr) term (with-term (cffc tnpr) term
(term cffc (gnrt1 tnpr)))) (term cffc (gnrt1 tnpr))))
tail)))))) tail))))))
;;; CLISP]+ ;;; CLISP]+
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (space (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (space
&aux (ls-hat-u-t (ls-hat-u-t space)) &aux (ls-hat-u-t (ls-hat-u-t space))
(cobar (cobar space))) (cobar (cobar space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-u-t cobar)) (type chain-complex ls-hat-u-t cobar))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc ls-hat-u-t :trgt cobar :degr 0 :sorc ls-hat-u-t :trgt cobar :degr 0
:intr #'ls-pre-left-hmeq-right-reduction-intr-f :intr #'ls-pre-left-hmeq-right-reduction-intr-f
:strt :cmbn :strt :cmbn
:orgn `(ls-pre-left-hmeq-right-reduction-f ,space)))) :orgn `(ls-pre-left-hmeq-right-reduction-f ,space))))
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (bspn) (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (bspn)
(declare (type gmsm bspn)) (declare (type gmsm bspn))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(let ((bsgn (tnpr 0 bspn 0 +null-loop+))) (let ((bsgn (tnpr 0 bspn 0 +null-loop+)))
(declare (type tnpr bsgn)) (declare (type tnpr bsgn))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc gnrt) term (cffc gnrt) term
(term cffc (tnpr degr gnrt 0 (term cffc (tnpr degr gnrt 0
bsgn)))) bsgn))))
list))))))) list)))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (space (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (space
&aux (ls-hat-u-t (ls-hat-u-t space)) &aux (ls-hat-u-t (ls-hat-u-t space))
(cobar (cobar space)) (cobar (cobar space))
(bspn (bspn space))) (bspn (bspn space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-u-t cobar) (type chain-complex ls-hat-u-t cobar)
(type gmsm bspn)) (type gmsm bspn))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc cobar :trgt ls-hat-u-t :degr 0 :sorc cobar :trgt ls-hat-u-t :degr 0
:intr (ls-pre-left-hmeq-right-reduction-intr-g bspn) :intr (ls-pre-left-hmeq-right-reduction-intr-g bspn)
:strt :cmbn :strt :cmbn
:orgn `(ls-pre-left-hmeq-right-reduction-g ,space)))) :orgn `(ls-pre-left-hmeq-right-reduction-g ,space))))
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (space (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (space
&aux (cobar (cobar space)) &aux (cobar (cobar space))
(tnpr-contraction (tnpr-contraction
(tnpr-contraction space))) (tnpr-contraction space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex cobar) (type chain-complex cobar)
@ -404,18 +404,18 @@
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(the reduction (the reduction
(build-rdct (build-rdct
:f (ls-pre-left-hmeq-right-reduction-f space) :f (ls-pre-left-hmeq-right-reduction-f space)
:g (ls-pre-left-hmeq-right-reduction-g space) :g (ls-pre-left-hmeq-right-reduction-g space)
:h (ls-pre-left-hmeq-right-reduction-h space) :h (ls-pre-left-hmeq-right-reduction-h space)
:orgn `(ls-pre-left-hmeq-right-reduction ,space)))) :orgn `(ls-pre-left-hmeq-right-reduction ,space))))
(DEFUN LS-LEFT-HMEQ-RIGHT-REDUCTION (space (DEFUN LS-LEFT-HMEQ-RIGHT-REDUCTION (space
&aux (pre-reduction &aux (pre-reduction
(ls-pre-left-hmeq-right-reduction (ls-pre-left-hmeq-right-reduction
space)) space))
(perturbation (perturbation
(ls-hat-left-perturbation space))) (ls-hat-left-perturbation space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type reduction pre-reduction) (type reduction pre-reduction)
@ -431,15 +431,15 @@
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(the homotopy-equivalence (the homotopy-equivalence
(build-hmeq (build-hmeq
:lrdct (ls-left-hmeq-left-reduction space) :lrdct (ls-left-hmeq-left-reduction space)
:rrdct (ls-left-hmeq-right-reduction space) :rrdct (ls-left-hmeq-right-reduction space)
:orgn `(ls-left-hmeq ,space)))) :orgn `(ls-left-hmeq ,space))))
(DEFUN LOOP-SPACE-EFHM (space) (DEFUN LOOP-SPACE-EFHM (space)
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(let ((ls-left-hmeq (ls-left-hmeq space)) (let ((ls-left-hmeq (ls-left-hmeq space))
(right-hmeq (cobar (efhm space)))) (right-hmeq (cobar (efhm space))))
(declare (type homotopy-equivalence ls-left-hmeq right-hmeq)) (declare (type homotopy-equivalence ls-left-hmeq right-hmeq))
(cmps ls-left-hmeq right-hmeq))) (cmps ls-left-hmeq right-hmeq)))

10
src/macros.lisp
View File

@ -76,6 +76,11 @@ and returns VALUE.
(DEFMACRO CFFC (term) (DEFMACRO CFFC (term)
"-----------------------------------------------------------------[macro-doc]
CFFC
Args: (term)
Returns the the coefficient (integer) of a term.
------------------------------------------------------------------------------"
`(car ,term)) `(car ,term))
@ -84,6 +89,11 @@ and returns VALUE.
(DEFMACRO GNRT (term) (DEFMACRO GNRT (term)
"-----------------------------------------------------------------[macro-doc]
GNRT
Args: (term)
Returns the the generator of a term.
------------------------------------------------------------------------------"
`(cdr ,term)) `(cdr ,term))

337
test/bar-test.lisp
View File

@ -1,4 +1,3 @@
(in-package :kenzo-test) (in-package :kenzo-test)
(in-suite :kenzo) (in-suite :kenzo)
@ -11,127 +10,126 @@
(test bar-cmpr (test bar-cmpr
(let ((r (cat:bar-cmpr #'cat:s-cmpr))) (let ((r (cat:bar-cmpr #'cat:s-cmpr)))
(is (equal :equal (funcall r (cat:abar) (cat:abar)))) (is (equal :equal (funcall r (cat:abar) (cat:abar))))
(is (equal :greater (funcall r (cat:abar 3 'a) (cat:abar)))) (is (equal :greater (funcall r (cat:abar 3 'a) (cat:abar))))
(is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 2 'a 1 'b)))) (is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 2 'a 1 'b))))
(is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 3 'b)))) (is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 3 'b))))
(is (equal :equal (funcall r (cat:abar 3 'a) (cat:abar 3 'a)))))) (is (equal :equal (funcall r (cat:abar 3 'a) (cat:abar 3 'a))))))
(test bar-basis-length (test bar-basis-length
(let ((basis #'(lambda (degr) (list degr)))) (let ((basis #'(lambda (degr) (list degr))))
(cat:bar-basis-length basis 2 1) (cat:bar-basis-length basis 2 1)
(cat:bar-basis-length basis 2 2) (cat:bar-basis-length basis 2 2)
(cat:bar-basis-length basis 3 1) (cat:bar-basis-length basis 3 1)
(cat:bar-basis-length basis 3 2) (cat:bar-basis-length basis 3 2)
(cat:bar-basis-length basis 4 1) (cat:bar-basis-length basis 4 1)
(cat:bar-basis-length basis 4 2) (cat:bar-basis-length basis 4 2)
(cat:bar-basis-length basis 4 3) (cat:bar-basis-length basis 4 3)
(cat:bar-basis-length basis 4 4) (cat:bar-basis-length basis 4 4)
(cat:bar-basis-length basis 8 1) (cat:bar-basis-length basis 8 1)
(cat:bar-basis-length basis 8 2) (cat:bar-basis-length basis 8 2)
(cat:bar-basis-length basis 8 3) (cat:bar-basis-length basis 8 3)
(cat:bar-basis-length basis 8 4) (cat:bar-basis-length basis 8 4)
(cat:bar-basis-length basis 8 5) (cat:bar-basis-length basis 8 5)
(cat:bar-basis-length basis 8 6) (cat:bar-basis-length basis 8 6)
(cat:bar-basis-length basis 8 11))) (cat:bar-basis-length basis 8 11)))
(test bar-basis (test bar-basis
(let* ((basis #'(lambda (degr) (list degr))) (let* ((basis #'(lambda (degr) (list degr)))
(r (cat:bar-basis basis))) (r (cat:bar-basis basis)))
(funcall r 0) (funcall r 0)
(funcall r 1) (funcall r 1)
(funcall r 2) (funcall r 2)
(dotimes (i 7) (dotimes (i 7)
(print (funcall r i))) (print (funcall r i)))
(cat:bar-basis :locally-effective))) (cat:bar-basis :locally-effective)))
(test bar-intr-vrtc-dffr (test bar-intr-vrtc-dffr
(let* ((d (cat:soft-delta-infinity)) (let* ((d (cat:soft-delta-infinity))
(r (cat:bar-intr-vrtc-dffr (cat:dffr d)))) (r (cat:bar-intr-vrtc-dffr (cat:dffr d))))
(funcall r 0 (cat:abar)) (funcall r 0 (cat:abar))
(funcall r 3 (cat:abar 3 (cat:d 7))) (funcall r 3 (cat:abar 3 (cat:d 7)))
(funcall r 5 (cat:abar 3 (cat:d 7) 2 (cat:d 3))) (funcall r 5 (cat:abar 3 (cat:d 7) 2 (cat:d 3)))
(funcall r 5 (cat:abar 2 (cat:d 3) 3 (cat:d 7))))) (funcall r 5 (cat:abar 2 (cat:d 3) 3 (cat:d 7)))))
(defun random-abar1 (length) (defun random-abar1 (length)
(let ((rslt nil)) (let ((rslt nil))
(dotimes (i length) (dotimes (i length)
(let* ((gmsm (random (cat:mask 7))) (let* ((gmsm (random (cat:mask 6)))
(dmns (1- (logcount gmsm)))) (dmns (1- (logcount gmsm))))
(when (plusp dmns) (when (plusp dmns)
(push (cat:brgn (1+ dmns) (cat:d gmsm)) rslt)))) (push (cat:brgn (1+ dmns) gmsm) rslt))))
(cat:make-abar :list rslt))) (cat:make-abar :list rslt)))
(test vrtc-bar (test vrtc-bar
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((v (cat:vrtc-bar (cat:soft-delta-infinity)))) (let ((v (cat:vrtc-bar (cat:delta-infinity))))
(dotimes (i 10) (dotimes (i 10)
(print (random-abar1 5))) (print (random-abar1 5)))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar1 3))) (let ((abar (random-abar1 3)))
(print abar) (print abar)
(print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar))) (print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar)) abar))
(print (cat:? v (cat:? v (apply #'+ (mapcar #'car (print (cat:? v (cat:? v (apply #'+ (mapcar #'car
(cat:abar-list abar))) (cat:abar-list abar)))
abar)))))))) abar))))))))
(test bar-intr-hrzn-dffr (test bar-intr-hrzn-dffr
(let* ((k (cat:k-z-1)) (let* ((k (cat:k-z-1))
(r (cat:bar-intr-hrzn-dffr (cat:aprd k)))) (r (cat:bar-intr-hrzn-dffr (cat:aprd k))))
(funcall r 0 (cat:abar )) (funcall r 0 (cat:abar ))
(funcall r 3 (cat:abar 3 '(2 3))) (funcall r 3 (cat:abar 3 '(2 3)))
(funcall r 6 (cat:abar 3 '(2 3) 3 '(-2 -3))) (funcall r 6 (cat:abar 3 '(2 3) 3 '(-2 -3)))
(funcall r 9 (cat:abar 3 '(2 3) 3 '(-2 -3) 3 '(2 3))) (funcall r 9 (cat:abar 3 '(2 3) 3 '(-2 -3) 3 '(2 3)))
(funcall r 11 (cat:abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3))))) (funcall r 11 (cat:abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3)))))
#|
(test bar-hrzn-dffr (test bar-hrzn-dffr
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((h (cat:bar-hrzn-dffr (cat:k-z-1))) (let ((h (cat:bar-hrzn-dffr (cat:k-z-1)))
(abar)) (abar))
(dotimes (i 10) (dotimes (i 10)
(print (random-abar 10 5))) (print (random-abar 10 5)))
(setf abar (random-abar 10 5)) (setf abar (random-abar 10 5))
(cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) abar) (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
(cat:? h (cat:? h (apply #'+ (mapcar #'car (cat:? h (cat:? h (apply #'+ (mapcar #'car
(cat:abar-list abar))) abar)) (cat:abar-list abar))) abar))
(dotimes (i 10) (dotimes (i 10)
(setf abar (random-abar 10 3)) (setf abar (random-abar 10 3))
(print abar) (print abar)
(print (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) (print (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar)) abar))
(print (cat:? h (cat:? h (apply #'+ (mapcar #'car (print (cat:? h (cat:? h (apply #'+ (mapcar #'car
(cat:abar-list abar))) (cat:abar-list abar)))
abar))))))) abar)))))))
|#
(test bar (test bar
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((b (cat:bar (cat:k-z-1))) (let ((b (cat:bar (cat:k-z-1)))
(abar (random-abar 10 3))) (abar (random-abar 10 3)))
(cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) abar) (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
(cat:? b (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) (cat:? b (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar)) abar))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 10 3))) (let ((abar (random-abar 10 3)))
(print abar) (print abar)
(print (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) (print (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar)) abar))
(print (cat:? b (print (cat:? b
(cat:? b (cat:? b
(apply #'+ (mapcar #'car (apply #'+ (mapcar #'car
(cat:abar-list abar))) (cat:abar-list abar)))
abar)))))))) abar))))))))
(test ncmbn-bar (test ncmbn-bar
@ -139,103 +137,102 @@
(cat:ncmbn-bar (list (cat:cmbn 3 2 'a 3 'b))) (cat:ncmbn-bar (list (cat:cmbn 3 2 'a 3 'b)))
(cat:ncmbn-bar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 2 4 'c 5 'd))) (cat:ncmbn-bar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 2 4 'c 5 'd)))
(cat:ncmbn-bar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 1 4 'c 5 'd) (cat:ncmbn-bar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 1 4 'c 5 'd)
(cat:cmbn 1 6 'e 7 'f)))) (cat:cmbn 1 6 'e 7 'f))))
(test mrph-vrtc-bar-intr (test mrph-vrtc-bar-intr
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr (let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective :basis :locally-effective
:intr-dffr #'cat:zero-mrph :intr-dffr #'cat:zero-mrph
:strt :cmbn)) :strt :cmbn))
(m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr (m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr
#'(lambda (degr gnrt) #'(lambda (degr gnrt)
(cat:cmbn degr 2 gnrt 3 (1+ gnrt))) (cat:cmbn degr 2 gnrt 3 (1+ gnrt)))
:strt :gnrt :orgn '(test))) :strt :gnrt :orgn '(test)))
(r (cat:mrph-vrtc-bar-intr m))) (r (cat:mrph-vrtc-bar-intr m)))
(funcall r 4 (cat:abar 2 3 2 4)))) (funcall r 4 (cat:abar 2 3 2 4))))
(test vrtc-bar (test vrtc-bar
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((f (cat:aw (cat:soft-delta-infinity) (let* ((f (cat:aw (cat:soft-delta-infinity)
(cat:soft-delta-infinity))) (cat:soft-delta-infinity)))
(cf (cat:vrtc-bar f))) (cf (cat:vrtc-bar f)))
(cat:? cf 6 (cat:abar 3 (cat:crpr 0 (cat:d 7) 0 (cat:d 7)) 3 (cat:? cf 6 (cat:abar 3 (cat:crpr 0 (cat:d 7) 0 (cat:d 7)) 3
(cat:crpr 0 (cat:d 56) 0 (cat:d 56))))))) (cat:crpr 0 (cat:d 56) 0 (cat:d 56)))))))
(test hmtp-vrtc-bar-intr (test hmtp-vrtc-bar-intr
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity))) (let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity)))
(h (cat:h ez)) (h (cat:h ez))
(gf (cat:cmps (cat:g ez) (cat:f ez))) (gf (cat:cmps (cat:g ez) (cat:f ez)))
(r (cat:hmtp-vrtc-bar-intr h gf))) (r (cat:hmtp-vrtc-bar-intr h gf)))
(funcall r 3 (cat:abar 3 (cat:crpr 0 7 0 7))) (funcall r 3 (cat:abar 3 (cat:crpr 0 7 0 7)))
(funcall r 9 (cat:abar 3 (cat:crpr 0 7 0 7) 3 (cat:crpr 0 14 0 14) (funcall r 9 (cat:abar 3 (cat:crpr 0 7 0 7) 3 (cat:crpr 0 14 0 14)
3 (cat:crpr 0 14 0 14)))))) 3 (cat:crpr 0 14 0 14))))))
#|
(test vrtc-bar1 (test vrtc-bar1
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((tcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(a b c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(a (cat:cmbn (1- degr) 1 'b 1 'd))
((b d) (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(tcc)))
(bcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(d (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(bcc)))
(f (cat:build-mrph :sorc tcc :trgt bcc :degr 0
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cat:cmbn degr 1 'c 1 'd))
(b (cat:cmbn degr))
((c d) (cat:cmbn degr 1 gnrt))))
:strt :gnrt :orgn '(f)))
(g (cat:build-mrph :sorc bcc :trgt tcc :degr 0
:intr #'identity :strt :cmbn :orgn '(g)))
(h (cat:build-mrph :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt)
(ecase gnrt
((a b) (cat:cmbn
(1+ degr)
1 'a -1 'b -1 'c -1 'd))
((c d) (cat:cmbn (1+ degr)))))
:strt :gnrt :orgn '(h)))
(rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct)))
(bar))
(cat:tcc rdct 3 'a)
(cat:g rdct (cat:f rdct 3 'a))
(cat:h rdct 3 'a)
(setf bar (cat:vrtc-bar rdct))
(cat:pre-check-rdct bar)
(aleat-tc)
(aleat-bc)
;;(loop (c))
(dotimes (i 10) (c))))) ;; degrees >= 15 is possible => error.
(let* ((tcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(a b c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(a (cat:cmbn (1- degr) 1 'b 1 'd))
((b d) (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(tcc)))
(bcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(d (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(bcc)))
(f (cat:build-mrph :sorc tcc :trgt bcc :degr 0
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cat:cmbn degr 1 'c 1 'd))
(b (cat:cmbn degr))
((c d) (cat:cmbn degr 1 gnrt))))
:strt :gnrt :orgn '(f)))
(g (cat:build-mrph :sorc bcc :trgt tcc :degr 0
:intr #'identity :strt :cmbn :orgn '(g)))
(h (cat:build-mrph :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt)
(ecase gnrt
((a b) (cat:cmbn
(1+ degr)
1 'a -1 'b -1 'c -1 'd))
((c d) (cat:cmbn (1+ degr)))))
:strt :gnrt :orgn '(h)))
(rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct)))
(bar))
(cat:tcc rdct 3 'a)
(cat:g rdct (cat:f rdct 3 'a))
(cat:h rdct 3 'a)
(setf bar (cat:vrtc-bar rdct))
(cat:pre-check-rdct bar)
(aleat-tc)
(aleat-bc)
;;(loop (c))
(dotimes (i 10) (c))))) ;; degrees >= 15 is possible => error.
|#
(test homology (test homology
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((h (cat:efhm (cat:k-z-1))) (let* ((h (cat:efhm (cat:k-z-1)))
(b (cat:bar h))) (b (cat:bar h)))
(cat:homology (cat:rbcc b) 0 11)))) (cat:homology (cat:rbcc b) 0 11))))

732
test/cl-space-efhm-test.lisp
View File

@ -1,456 +1,372 @@
(in-package :kenzo-test) (in-package :kenzo-test)
(in-suite :kenzo) (in-suite :kenzo)
#|
(test cs-hat-u-t (test cs-hat-u-t
(cat:cat-init) (cat:cat-init)
(let* ((c (cat:cs-hat-u-t (cat:k-z-1))) (let ((c (cat:cs-hat-u-t (cat:k-z-1)))
(abar (random-abar 8 4)) abar-degr
(abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) gnrt)
(gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '()) (dotimes (i 10)
2 '(4 5)) (let ((abar (random-abar 8 4)))
abar-degr abar))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(cat:? c (+ 5 abar-degr) gnrt) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) gnrt)))) 0 '()) 2 '(4 5))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 10)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 5 abar-degr) gnrt))
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
0 '()) 2 '(4 5)) gnrt)))))))
abar-degr abar)) (dotimes (i 10)
(unless (>= abar-degr 10) (let ((abar (random-abar 8 4)))
(print (cat:? c (+ 5 abar-degr) gnrt)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
gnrt))))))) 0 '()) 3 '(4 5 6))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 9)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 6 abar-degr) gnrt))
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
0 '()) 3 '(4 5 6)) gnrt)))))))
abar-degr abar)) (dotimes (i 10)
(unless (>= abar-degr 9) (let ((abar (random-abar 8 4)))
(print (cat:? c (+ 6 abar-degr) gnrt)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr) (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
gnrt))))))) 3 '(4 5 6)) abar-degr abar))
(dotimes (i 10) (unless (>= abar-degr 10)
(let ((abar (random-abar 8 4))) (print (cat:? c (+ 5 abar-degr) gnrt))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) gnrt)))))))
3 '(4 5 6)) abar-degr abar)) (dotimes (i 10)
(unless (>= abar-degr 10) (let ((abar (random-abar 8 4)))
(print (cat:? c (+ 5 abar-degr) gnrt)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
gnrt))))))) 2 '(4 5))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 11)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 4 abar-degr) gnrt))
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
2 '(4 5)) gnrt)))))))))
abar-degr abar))
(unless (>= abar-degr 11)
(print (cat:? c (+ 4 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
gnrt)))))))))
|#
#|
(test cs-hat-t-u (test cs-hat-t-u
(cat:cat-init) (cat:cat-init)
(dotimes (i 5) (print (random-abar 8 4))) (dotimes (i 5) (print (random-abar 8 4)))
(let* ((c (cat:cs-hat-t-u (cat:k-z-1))) (let ((c (cat:cs-hat-t-u (cat:k-z-1)))
(abar (random-abar 8 4)) abar-degr
(abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) gnrt)
(gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '()) (dotimes (i 10)
2 '(4 5)) (let ((abar (random-abar 8 4)))
abar-degr abar))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(cat:? c (+ 5 abar-degr) gnrt) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) gnrt)))) 0 '()) 2 '(4 5))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 10)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 5 abar-degr) gnrt))
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
0 '()) 2 '(4 5)) gnrt)))))))
abar-degr abar)) (dotimes (i 10)
(unless (>= abar-degr 10) (let ((abar (random-abar 8 4)))
(print (cat:? c (+ 5 abar-degr) gnrt)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
gnrt))))))) 0 '()) 3 '(4 5 6))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 9)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 6 abar-degr) gnrt))
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
0 '()) 3 '(4 5 6)) gnrt)))))))
abar-degr abar)) (dotimes (i 10)
(unless (>= abar-degr 9) (let ((abar (random-abar 8 4)))
(print (cat:? c (+ 6 abar-degr) gnrt)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr) (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
gnrt))))))) 3 '(4 5 6))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 10)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 5 abar-degr) gnrt))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
3 '(4 5 6)) gnrt)))))))
abar-degr abar)) (dotimes (i 10)
(unless (>= abar-degr 10) (let ((abar (random-abar 8 4)))
(print (cat:? c (+ 5 abar-degr) gnrt)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
gnrt))))))) 2 '(4 5))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 11)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 4 abar-degr) gnrt))
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
2 '(4 5)) gnrt)))))))))
abar-degr abar))
(unless (>= abar-degr 11)
(print (cat:? c (+ 4 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
gnrt)))))))))
|#
#|
(test cs-left-hmeq-hat (test cs-left-hmeq-hat
(cat:cat-init) (cat:cat-init)
(let ((c (cat:cs-left-hmeq-hat (cat:k-z-1))) (let ((c (cat:cs-left-hmeq-hat (cat:k-z-1)))
abar-degr abar-degr
gnrt) gnrt)
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 2 '(4 5)) 0 '()) 2 '(4 5))
abar-degr abar)) abar-degr abar))
(unless (>= abar-degr 10) (unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt)) (print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt))))))) gnrt)))))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 3 '(4 5 6)) 0 '()) 3 '(4 5 6))
abar-degr abar)) abar-degr abar))
(unless (>= abar-degr 9) (unless (>= abar-degr 9)
(print (cat:? c (+ 6 abar-degr) gnrt)) (print (cat:? c (+ 6 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
gnrt))))))) gnrt)))))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6)) 3 '(4 5 6))
abar-degr abar)) abar-degr abar))
(unless (>= abar-degr 10) (unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt)) (print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt))))))) gnrt)))))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
2 '(4 5)) 2 '(4 5))
abar-degr abar)) abar-degr abar))
(unless (>= abar-degr 11) (unless (>= abar-degr 11)
(print (cat:? c (+ 4 abar-degr) gnrt)) (print (cat:? c (+ 4 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
gnrt))))))))) gnrt)))))))))
|#
(test cs-pre-left-hmeq-left-reduction-intr-f
(cat:cs-pre-left-hmeq-left-reduction-intr-f
(cat:cmbn 6 100 (cat:tnpr 4 (cat:tnpr 2 'a 2 'b) 2 'c)
10 (cat:tnpr 6 (cat:tnpr 2 'a 4 'b) 0 'c)
50 (cat:tnpr 6 (cat:tnpr 6 'a 0 'b) 0 'c)
1 (cat:tnpr 6 (cat:tnpr 6 'aa 0 'b) 0 'c))))
(test cs-pre-left-hmeq-left-reduction-intr-g
(let ((g (cat:cs-pre-left-hmeq-left-reduction-intr-g '())))
(funcall g (cat:cmbn 3 14 (cat:gbar 3 0 'a 1 'b 0 '())))))
#|
(test cs-pre-left-hmeq-left-reduction (test cs-pre-left-hmeq-left-reduction
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:cs-pre-left-hmeq-left-reduction (cat:k-z-1))) (let ((rdct (cat:cs-pre-left-hmeq-left-reduction (cat:k-z-1)))
abar-degr abar-degr
gnrt gnrt
gbar) gbar)
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (dotimes (i 10)
(cat:tnpr 0 (cat:tnpr 0 (let ((abar (random-abar 8 4)))
cat:+null-gbar+ 0 '()) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
0 cat:+null-abar+)) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
cat:*bc* (cat:cmbn 0 1 cat:+null-gbar+)) 0 '()) 2 '(4 5))
(check-rdct) abar-degr abar))
(setf cat:*tc* (cat:cmbn 1 1 (setf gbar (cat:gbar 2 0 '(1) 0 '()))
(cat:tnpr 1 (cat:tnpr 0 (unless (>= abar-degr 9)
cat:+null-gbar+ 1 '(13)) (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
0 cat:+null-abar+))) cat:*bc* (cat:cmbn 2 1 gbar))
(check-rdct) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 2 '(4 5)) 0 '()) 3 '(4 5 6))
abar-degr abar)) abar-degr abar))
(setf gbar (cat:gbar 2 0 '(1) 0 '())) (setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '()))
(unless (>= abar-degr 9) (unless (>= abar-degr 8)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt) (setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn 2 1 gbar)) cat:*bc* (cat:cmbn 3 1 gbar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
0 '()) 3 '(4 5 6)) 3 '(4 5 6))
abar-degr abar)) abar-degr abar))
(setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '())) (setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
(unless (>= abar-degr 8) (unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt) (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
cat:*bc* (cat:cmbn 3 1 gbar)) (setf cat:*bc* (cat:cmbn 4 1 gbar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6)) 2 '(4 5))
abar-degr abar)) abar-degr abar))
(setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '())) (setf gbar (cat:gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9)
(unless (>= abar-degr 9) 0 '()))
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)) (unless (>= abar-degr 10)
(setf cat:*bc* (cat:cmbn 4 1 gbar)) (setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(check-rdct)))) (setf cat:*bc* (cat:cmbn 5 1 gbar))
(dotimes (i 10) (check-rdct))))))
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
2 '(4 5))
abar-degr abar))
(setf gbar (cat:gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9)
0 '()))
(unless (>= abar-degr 10)
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn 5 1 gbar))
(check-rdct))))))
|#
#|
(test cs-left-hmeq-left-reduction (test cs-left-hmeq-left-reduction
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:cs-left-hmeq-left-reduction (cat:k-z-1))) (let ((rdct (cat:cs-left-hmeq-left-reduction (cat:k-z-1)))
abar-degr gnrt gbar) abar-degr
(cat:pre-check-rdct rdct) gnrt
(setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0 gbar)
(cat:tnpr 0 cat:+null-gbar+ (cat:pre-check-rdct rdct)
0 '()) 0 (dotimes (i 10)
cat:+null-abar+)) (let ((abar (random-abar 8 4)))
cat:*bc* (cat:cmbn 0 1 cat:+null-gbar+)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(check-rdct) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
(setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 1 0 '()) 2 '(4 5))
(cat:tnpr 0 cat:+null-gbar+ abar-degr abar))
1 '(13)) 0 (setf gbar (cat:gbar 2 0 '(1) 0 '()))
cat:+null-abar+))) (unless (>= abar-degr 9)
(check-rdct) (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
(dotimes (i 10) cat:*bc* (cat:cmbn 2 1 gbar))
(let ((abar (random-abar 8 4))) (check-rdct))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (dotimes (i 10)
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (let ((abar (random-abar 6 4)))
0 '()) 2 '(4 5)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
abar-degr abar)) (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
(setf gbar (cat:gbar 2 0 '(1) 0 '())) 0 '()) 3 '(4 5 6))
(unless (>= abar-degr 9) abar-degr abar))
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt) (setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '()))
cat:*bc* (cat:cmbn 2 1 gbar)) (unless (>= abar-degr 8)
(check-rdct)))) (setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
(dotimes (i 10) cat:*bc* (cat:cmbn 3 1 gbar))
(let ((abar (random-abar 6 4))) (check-rdct))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (dotimes (i 10)
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (let ((abar (random-abar 6 4)))
0 '()) 3 '(4 5 6)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
abar-degr abar)) (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
(setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '())) 3 '(4 5 6))
(unless (>= abar-degr 8) abar-degr abar))
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt) (setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
cat:*bc* (cat:cmbn 3 1 gbar)) (unless (>= abar-degr 9)
(check-rdct)))) (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(dotimes (i 10) (setf cat:*bc* (cat:cmbn 4 1 gbar))
(let ((abar (random-abar 6 4))) (check-rdct))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (dotimes (i 10)
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (let ((abar (random-abar 6 4)))
3 '(4 5 6)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
abar-degr abar)) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
(setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '())) 2 '(4 5))
(unless (>= abar-degr 9) abar-degr abar))
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)) (setf gbar (cat:gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9)
(setf cat:*bc* (cat:cmbn 4 1 gbar)) 0 '()))
(check-rdct)))) (unless (>= abar-degr 10)
(dotimes (i 10) (setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(let ((abar (random-abar 6 4))) (setf cat:*bc* (cat:cmbn 5 1 gbar))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (check-rdct))))))
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
2 '(4 5))
abar-degr abar))
(setf gbar (cat:gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9)
0 '()))
(unless (>= abar-degr 10)
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn 5 1 gbar))
(check-rdct))))))
|#
(test cs-pre-left-hmeq-right-reduction-intr-f (test cs-pre-left-hmeq-right-reduction-intr-f
(cat:cs-pre-left-hmeq-right-reduction-intr-f (cat:cs-pre-left-hmeq-right-reduction-intr-f
(cat:cmbn 4 2 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i) (cat:cmbn 4 2 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i)
4 (cat:abar 2 'a 2 'b)) 4 (cat:abar 2 'a 2 'b))
3 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i) 3 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i)
4 (cat:abar 2 'a 2 'c)) 4 (cat:abar 2 'a 2 'c))
5 (cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+ 1 'a) 5 (cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+ 1 'a)
3 (cat:abar 1 'a 2 'b))))) 3 (cat:abar 1 'a 2 'b)))))
(test cs-pre-left-hmeq-right-reduction-g (test cs-pre-left-hmeq-right-reduction-g
(let ((g (cat:cs-pre-left-hmeq-right-reduction-intr-g 'i))) (let ((g (cat:cs-pre-left-hmeq-right-reduction-intr-g 'i)))
(funcall g (cat:cmbn 3 2 (cat:abar 1 'a 2 'b))))) (funcall g (cat:cmbn 3 2 (cat:abar 1 'a 2 'b)))))
#|
(test cs-pre-left-hmeq-right-reduction (test cs-pre-left-hmeq-right-reduction
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:cs-pre-left-hmeq-right-reduction (cat:k-z-1))) (let ((rdct (cat:cs-pre-left-hmeq-right-reduction (cat:k-z-1)))
abar-degr abar-degr
gnrt) gnrt)
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0 (dotimes (i 10)
(cat:tnpr 0 cat:+null-gbar+ (let ((abar (random-abar 8 4)))
0 '()) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
0 cat:+null-abar+)) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
cat:*bc* (cat:cmbn 0 1 cat:+null-abar+)) 0 '()) 2 '(4 5))
(check-rdct) abar-degr abar))
(setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 1 (unless (>= abar-degr 9)
(cat:tnpr 0 cat:+null-gbar+ (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
1 '(13)) cat:*bc* (cat:cmbn abar-degr 1 abar))
0 cat:+null-abar+))) (check-rdct))))
(check-rdct) (dotimes (i 10)
(dotimes (i 10) (let ((abar (random-abar 6 4)))
(let ((abar (random-abar 8 4))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
0 '()) 2 '(4 5)) abar-degr abar))
abar-degr abar)) (unless (>= abar-degr 8)
(unless (>= abar-degr 9) (setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt) cat:*bc* (cat:cmbn abar-degr 1 abar))
cat:*bc* (cat:cmbn abar-degr 1 abar)) (check-rdct))))
(check-rdct)))) (dotimes (i 10)
(dotimes (i 10) (let ((abar (random-abar 6 4)))
(let ((abar (random-abar 6 4))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 3 '(4 5 6))
0 '()) 3 '(4 5 6)) abar-degr abar))
abar-degr abar)) (unless (>= abar-degr 9)
(unless (>= abar-degr 8) (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt) (setf cat:*bc* (cat:cmbn abar-degr 1 abar))
cat:*bc* (cat:cmbn abar-degr 1 abar)) (check-rdct))))
(check-rdct)))) (dotimes (i 10)
(dotimes (i 10) (let ((abar (random-abar 6 4)))
(let ((abar (random-abar 6 4))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) 2 '(4 5))
3 '(4 5 6)) abar-degr abar))
abar-degr abar)) (unless (>= abar-degr 10)
(unless (>= abar-degr 9) (setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)) (setf cat:*bc* (cat:cmbn abar-degr 1 abar))
(setf cat:*bc* (cat:cmbn abar-degr 1 abar)) (check-rdct))))))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
(check-rdct))))))
|#
#|
(test cs-left-hmeq-right-reduction (test cs-left-hmeq-right-reduction
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:cs-left-hmeq-right-reduction (cat:k-z-1))) (let ((rdct (cat:cs-left-hmeq-right-reduction (cat:k-z-1)))
abar-degr abar-degr
gnrt) gnrt)
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (dotimes (i 10)
(cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ (let ((abar (random-abar 4 2)))
0 '()) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
0 cat:+null-abar+)) (setf gnrt (cat:tnpr 3 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
cat:*bc* (cat:cmbn 0 1 cat:+null-abar+)) 1 '(4))
(check-rdct) abar-degr abar))
(setf cat:*tc* (cat:cmbn 1 1 (unless (>= abar-degr 9)
(cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+ (setf cat:*tc* (cat:cmbn (+ 3 abar-degr) 1 gnrt)
1 '(13)) cat:*bc* (cat:cmbn abar-degr 1 abar))
0 cat:+null-abar+))) (check-rdct))))
(check-rdct) (dotimes (i 10)
(dotimes (i 10) (let ((abar (random-abar 3 1)))
(let ((abar (random-abar 4 2))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
(setf gnrt (cat:tnpr 3 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) 2 '(5 6))
1 '(4)) abar-degr abar))
abar-degr abar)) (unless (>= abar-degr 8)
(unless (>= abar-degr 9) (setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt)
(setf cat:*tc* (cat:cmbn (+ 3 abar-degr) 1 gnrt) cat:*bc* (cat:cmbn abar-degr 1 abar))
cat:*bc* (cat:cmbn abar-degr 1 abar)) (check-rdct))))
(check-rdct)))) (dotimes (i 10)
(dotimes (i 10) (let ((abar (random-abar 3 1)))
(let ((abar (random-abar 3 1))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 1 '()
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) 0 '()) 2 '(5 6))
2 '(5 6)) abar-degr abar))
abar-degr abar)) (unless (>= abar-degr 9)
(unless (>= abar-degr 8) (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt) (setf cat:*bc* (cat:cmbn abar-degr 1 abar))
cat:*bc* (cat:cmbn abar-degr 1 abar)) (check-rdct))))))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 3 1)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 1 '()
0 '()) 2 '(5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
(check-rdct))))))
|#
(test cs-left-hmeq (test cs-left-hmeq
(cat:cat-init) (cat:cat-init)
(let* ((h (cat:cs-left-hmeq (cat:k-z-1))) (let* ((h (cat:cs-left-hmeq (cat:k-z-1)))
(abar (cat:abar 2 '(2) 3 '(3 4)))) (abar (cat:abar 2 '(2) 3 '(3 4))))
(cat:rf h (cat:rf h
(cat:lg h (cat:lg h
(cat:lf h (cat:lf h
(cat:rg h 5 abar)))))) (cat:rg h 5 abar))))))
(test classifying-space (test classifying-space
(cat:cat-init) (cat:cat-init)
(let* ((k (cat:k-z-1)) (let* ((k (cat:k-z-1))
(bk (cat:classifying-space k)) (bk (cat:classifying-space k))
(obk (cat:loop-space bk))) (obk (cat:loop-space bk)))
(cat:homology k 0 10) (cat:homology k 0 10)
(cat:homology bk 0 10) (cat:homology bk 0 10)
(cat:homology obk 0 6))) (cat:homology obk 0 6)))

218
test/common.lisp
View File

@ -22,36 +22,36 @@
(defun cdelta (dmns) (defun cdelta (dmns)
(the cat:chain-complex (the cat:chain-complex
(cat:build-chcm (cat:build-chcm
:cmpr #'cat:l-cmpr :cmpr #'cat:l-cmpr
:basis :locally-effective :basis :locally-effective
:bsgn '(0) :bsgn '(0)
:intr-dffr #'(lambda (degr gmsm) :intr-dffr #'(lambda (degr gmsm)
(cat:make-cmbn (cat:make-cmbn
:degr (1- degr) :degr (1- degr)
:list (do ((rslt cat:+empty-list+ :list (do ((rslt cat:+empty-list+
(cons (cons sign (cons (cons sign
(append (append
(subseq gmsm 0 nark) (subseq gmsm 0 nark)
(subseq gmsm (1+ nark)))) (subseq gmsm (1+ nark))))
rslt)) rslt))
(sign 1 (- sign)) (sign 1 (- sign))
(nark 0 (1+ nark))) (nark 0 (1+ nark)))
((> nark degr) rslt)))) ((> nark degr) rslt))))
:strt :gnrt :strt :gnrt
:orgn `(locally effective version of C_* delta ,dmns)))) :orgn `(locally effective version of C_* delta ,dmns))))
(defun make-f (tdmns bdmns) (defun make-f (tdmns bdmns)
(cat:build-mrph (cat:build-mrph
:sorc (cdelta tdmns) :trgt (cdelta bdmns) :degr 0 :sorc (cdelta tdmns) :trgt (cdelta bdmns) :degr 0
:intr #'(lambda (degr gmsm) :intr #'(lambda (degr gmsm)
(let ((pos (position-if #'(lambda (vertex) (let ((pos (position-if #'(lambda (vertex)
(>= vertex bdmns)) gmsm))) (>= vertex bdmns)) gmsm)))
(if pos (if pos
(if (< pos degr) (if (< pos degr)
(cat:zero-cmbn degr) (cat:zero-cmbn degr)
(cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns)))) (cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns))))
(cat:cmbn degr 1 gmsm)))) (cat:cmbn degr 1 gmsm))))
:strt :gnrt :strt :gnrt
:orgn `(projection delta ,tdmns => delta ,bdmns))) :orgn `(projection delta ,tdmns => delta ,bdmns)))
@ -68,44 +68,44 @@
(cat:build-mrph (cat:build-mrph
:sorc (cdelta tdmns) :trgt (cdelta tdmns) :degr +1 :sorc (cdelta tdmns) :trgt (cdelta tdmns) :degr +1
:intr #'(lambda (degr gmsm) :intr #'(lambda (degr gmsm)
(let ((pos (position-if #'(lambda (vertex) (let ((pos (position-if #'(lambda (vertex)
(>= vertex bdmns)) gmsm))) (>= vertex bdmns)) gmsm)))
(if pos (if pos
(if (member bdmns gmsm) (if (member bdmns gmsm)
(cat:zero-cmbn (1+ degr)) (cat:zero-cmbn (1+ degr))
(cat:cmbn (1+ degr) (cat:-1-expt-n pos) (cat:cmbn (1+ degr) (cat:-1-expt-n pos)
(append (subseq gmsm 0 pos) (list bdmns) (append (subseq gmsm 0 pos) (list bdmns)
(subseq gmsm pos)))) (subseq gmsm pos))))
(cat:zero-cmbn (1+ degr))))) (cat:zero-cmbn (1+ degr)))))
:strt :gnrt :strt :gnrt
:orgn `(homotopy for delta ,tdmns => ,bdmns))) :orgn `(homotopy for delta ,tdmns => ,bdmns)))
(defun make-rdct (tdmns bdmns) (defun make-rdct (tdmns bdmns)
(let ((rdct (cat:build-rdct (let ((rdct (cat:build-rdct
:f (make-f tdmns bdmns) :f (make-f tdmns bdmns)
:g (make-g tdmns bdmns) :g (make-g tdmns bdmns)
:h (make-h tdmns bdmns) :h (make-h tdmns bdmns)
:orgn `(reduction delta ,tdmns ,bdmns)))) :orgn `(reduction delta ,tdmns ,bdmns))))
rdct)) rdct))
(defun cdelta1 (dmns) (defun cdelta1 (dmns)
(cat:build-chcm (cat:build-chcm
:cmpr #'cat:l-cmpr :cmpr #'cat:l-cmpr
:basis #'(lambda (n) :basis #'(lambda (n)
(mapcar #'cat:dlop-int-ext (funcall (cat:delta-n-basis dmns) n))) (mapcar #'cat:dlop-int-ext (funcall (cat:delta-n-basis dmns) n)))
:bsgn '(0) :bsgn '(0)
:intr-dffr #'(lambda (degr gmsm) :intr-dffr #'(lambda (degr gmsm)
(cat:make-cmbn (cat:make-cmbn
:degr (1- degr) :degr (1- degr)
:list (do ((rslt cat:+empty-list+ :list (do ((rslt cat:+empty-list+
(cons (cons sign (append (cons (cons sign (append
(subseq gmsm 0 nark) (subseq gmsm 0 nark)
(subseq gmsm (1+ nark)))) (subseq gmsm (1+ nark))))
rslt)) rslt))
(sign 1 (- sign)) (sign 1 (- sign))
(nark 0 (1+ nark))) (nark 0 (1+ nark)))
((> nark degr) rslt)))) ((> nark degr) rslt))))
:strt :gnrt :strt :gnrt
:orgn `(locally effective version of C_* delta ,dmns))) :orgn `(locally effective version of C_* delta ,dmns)))
@ -113,13 +113,13 @@
(cat:build-mrph (cat:build-mrph
:sorc (cdelta1 tdmns) :trgt (cdelta1 bdmns) :degr 0 :sorc (cdelta1 tdmns) :trgt (cdelta1 bdmns) :degr 0
:intr #'(lambda (degr gmsm) :intr #'(lambda (degr gmsm)
(let ((pos (position-if #'(lambda (vertex) (let ((pos (position-if #'(lambda (vertex)
(>= vertex bdmns)) gmsm))) (>= vertex bdmns)) gmsm)))
(if pos (if pos
(if (< pos degr) (if (< pos degr)
(cat:zero-cmbn degr) (cat:zero-cmbn degr)
(cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns)))) (cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns))))
(cat:cmbn degr 1 gmsm)))) (cat:cmbn degr 1 gmsm))))
:strt :gnrt :strt :gnrt
:orgn `(projection delta ,tdmns => delta ,bdmns))) :orgn `(projection delta ,tdmns => delta ,bdmns)))
@ -136,58 +136,58 @@
(cat:build-mrph (cat:build-mrph
:sorc (cdelta1 tdmns) :trgt (cdelta1 tdmns) :degr +1 :sorc (cdelta1 tdmns) :trgt (cdelta1 tdmns) :degr +1
:intr #'(lambda (degr gmsm) :intr #'(lambda (degr gmsm)
(let ((pos (position-if #'(lambda (vertex) (let ((pos (position-if #'(lambda (vertex)
(>= vertex bdmns)) gmsm))) (>= vertex bdmns)) gmsm)))
(if pos (if pos
(if (member bdmns gmsm) (if (member bdmns gmsm)
(cat:zero-cmbn (1+ degr)) (cat:zero-cmbn (1+ degr))
(cat:cmbn (1+ degr) (cat:-1-expt-n pos) (cat:cmbn (1+ degr) (cat:-1-expt-n pos)
(append (subseq gmsm 0 pos) (list bdmns) (append (subseq gmsm 0 pos) (list bdmns)
(subseq gmsm pos)))) (subseq gmsm pos))))
(cat:zero-cmbn (1+ degr))))) (cat:zero-cmbn (1+ degr)))))
:strt :gnrt :strt :gnrt
:orgn `(homotopy for delta ,tdmns => ,bdmns))) :orgn `(homotopy for delta ,tdmns => ,bdmns)))
(defun make-rdct1 (tdmns bdmns) (defun make-rdct1 (tdmns bdmns)
(let ((rdct (cat:build-rdct (let ((rdct (cat:build-rdct
:f (make-f1 tdmns bdmns) :f (make-f1 tdmns bdmns)
:g (make-g1 tdmns bdmns) :g (make-g1 tdmns bdmns)
:h (make-h1 tdmns bdmns) :h (make-h1 tdmns bdmns)
:orgn `(reduction delta ,tdmns ,bdmns)))) :orgn `(reduction delta ,tdmns ,bdmns))))
rdct)) rdct))
(defun check-rdct () (defun check-rdct ()
(dolist (phi '(cat:*tdd* cat:*bdd* cat:*df-fd* cat:*dg-gd* cat:*id-fg* (dolist (phi '(cat:*tdd* cat:*bdd* cat:*df-fd* cat:*dg-gd* cat:*id-fg*
cat:*id-gf-dh-hd* cat:*hh* cat:*fh* cat:*hg*)) cat:*id-gf-dh-hd* cat:*hh* cat:*fh* cat:*hg*))
(declare (type symbol phi)) (declare (type symbol phi))
(is (cat:cmbn-zero-p (is (cat:cmbn-zero-p
(cat:cmbn-? (eval phi) (cat:cmbn-? (eval phi)
(if (member phi '(cat:*bdd* cat:*dg-gd* cat:*id-fg* (if (member phi '(cat:*bdd* cat:*dg-gd* cat:*id-fg*
cat:*dg-gd* cat:*hg*)) cat:*dg-gd* cat:*hg*))
cat:*bc* cat:*bc*
cat:*tc*)))))) cat:*tc*))))))
(defun aleat-tc () (defun aleat-tc ()
(do ((tdegr 0 (+ tdegr degr)) (do ((tdegr 0 (+ tdegr degr))
(degr (+ 2 (random 3)) (+ 2 (random 3))) (degr (+ 2 (random 3)) (+ 2 (random 3)))
(gnrt (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string)) (gnrt (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))
(intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))) (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string)))
(rslt nil (cons (cat:brgn degr gnrt) rslt))) (rslt nil (cons (cat:brgn degr gnrt) rslt)))
((> tdegr 10) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar ((> tdegr 8) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt)))))) :list rslt))))))
(defun aleat-bc () (defun aleat-bc ()
(do ((tdegr 0 (+ tdegr degr)) (do ((tdegr 0 (+ tdegr degr))
(degr (1+ (random 4)) (1+ (random 4))) (degr (1+ (random 4)) (1+ (random 4)))
(gnrt (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string)) (gnrt (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))
(intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))) (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string)))
(rslt nil (cons (cat:brgn degr gnrt) rslt))) (rslt nil (cons (cat:brgn degr gnrt) rslt)))
((> tdegr 10) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar ((> tdegr 8) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt)))))) :list rslt))))))
(defun c () (defun c ()
@ -203,53 +203,53 @@
((>= cum-degr tot-degr~) (cat:make-abar :list rslt)) ((>= cum-degr tot-degr~) (cat:make-abar :list rslt))
(setf degr (1+ (random max-degr))) (setf degr (1+ (random max-degr)))
(push (cat:brgn (1+ degr) (push (cat:brgn (1+ degr)
(let ((list (make-list degr))) (let ((list (make-list degr)))
(mapl (mapl
#'(lambda (sublist) #'(lambda (sublist)
(setf (car sublist) (- (random 21) 10))) (setf (car sublist) (- (random 21) 10)))
list) list)
list)) list))
rslt))) rslt)))
(defun random-allp (length) (defun random-allp (length)
(let ((rslt nil)) (let ((rslt nil))
(dotimes (i length) (dotimes (i length)
(let* ((gmsm (random (cat:mask 9))) (let* ((gmsm (random (cat:mask 9)))
(dmns (1- (logcount gmsm)))) (dmns (1- (logcount gmsm))))
(when (plusp dmns) (when (plusp dmns)
(push (cat:cbgn (1- dmns) gmsm) rslt)))) (push (cat:cbgn (1- dmns) gmsm) rslt))))
(cat:make-allp :list rslt))) (cat:make-allp :list rslt)))
(defun random-apowr (dmns max-expn) (defun random-apowr (dmns max-expn)
(loop (loop
(let* ((dgop (random (cat:2-exp (1- dmns)))) (let* ((dgop (random (cat:2-exp (1- dmns))))
(gmsm (- dmns (logcount dgop)))) (gmsm (- dmns (logcount dgop))))
(unless (< 0 gmsm 3) (unless (< 0 gmsm 3)
(return-from random-apowr (return-from random-apowr
(cat:apowr dgop gmsm (cat:srandom max-expn))))))) (cat:apowr dgop gmsm (cat:srandom max-expn)))))))
(defun random-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length) (defun random-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
(apply #'cat:nterm-add cmpr degr (apply #'cat:nterm-add cmpr degr
(mapcar #'(lambda (dummy) (mapcar #'(lambda (dummy)
(declare (ignore dummy)) (declare (ignore dummy))
(cat:term (cat:srandom max-cffc) (cat:term (cat:srandom max-cffc)
(random-crpr degr max-expn loop-length))) (random-crpr degr max-expn loop-length)))
(make-list cmbn-length)))) (make-list cmbn-length))))
(defun random-crpr (dmns max-expn length) (defun random-crpr (dmns max-expn length)
(loop (loop
(let ((loop (cat:normalize-loop dmns (let ((loop (cat:normalize-loop dmns
(random-niloop dmns max-expn length))) (random-niloop dmns max-expn length)))
(dgop (random (cat:2-exp dmns)))) (dgop (random (cat:2-exp dmns))))
(let ((absm (cat:2absm-acrpr (cat:absm dgop (- dmns (logcount dgop))) (let ((absm (cat:2absm-acrpr (cat:absm dgop (- dmns (logcount dgop)))
loop))) loop)))
(when (and (zerop (cat:dgop absm)) (when (and (zerop (cat:dgop absm))
(not (< (cat:gmsm1 (cat:gmsm absm)) 3))) (not (< (cat:gmsm1 (cat:gmsm absm)) 3)))
(return (cat:gmsm absm))))))) (return (cat:gmsm absm)))))))
(defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length) (defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
@ -259,13 +259,13 @@
((zerop i) ((zerop i)
(apply #'cat:nterm-add cmpr degr rslt)) (apply #'cat:nterm-add cmpr degr rslt))
(setf term (setf term
(cat:term (cat:srandom max-cffc) (cat:term (cat:srandom max-cffc)
(cat:make-loop :list (random-niloop degr max-expn (cat:make-loop :list (random-niloop degr max-expn
loop-length)))))) loop-length))))))
(defun random-niloop (dmns max-expn length) (defun random-niloop (dmns max-expn length)
(mapcar #'(lambda (dummy) (mapcar #'(lambda (dummy)
(declare (ignore dummy)) (declare (ignore dummy))
(random-apowr (1+ dmns) max-expn)) (random-apowr (1+ dmns) max-expn))
(make-list length))) (make-list length)))

403
test/lp-space-efhm-test.lisp
View File

@ -1,198 +1,173 @@
(in-package :kenzo-test) (in-package :kenzo-test)
(in-suite :kenzo) (in-suite :kenzo)
#|
(test ls-hat-t-u (test ls-hat-t-u
(cat:cat-init) (cat:cat-init)
(let ((c (cat:ls-hat-t-u (cat:deltab))) (let ((c (cat:ls-hat-t-u (cat:deltab)))
allp allp-degr gnrt) allp allp-degr gnrt)
(dotimes (i 10) (print (random-allp 5))) (dotimes (i 10)
(setf allp (random-allp 4)) ;; the degree could be too big (let ((allp (random-allp 3)))
;; then redo (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf gnrt (cat:tnpr allp-degr allp 4
(setf gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (unless (>= allp-degr 11)
(cat:? c (+ 4 allp-degr) gnrt) (print (cat:? c (+ 4 allp-degr) gnrt))
(cat:? c *) (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt))))))
(dotimes (i 10) (dotimes (i 20)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 4 (setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (cat:tnpr 3 15 2 (cat:loop3 0 15 2))))
(unless (>= allp-degr 11) (unless (>= allp-degr 10)
(print (cat:? c (+ 4 allp-degr) gnrt)) (print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))
(dotimes (i 20) (dotimes (i 20)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5 (setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) (cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(unless (>= allp-degr 10) (unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt)) (print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
(dotimes (i 20)
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
|#
#|
(test ls-hat-u-t (test ls-hat-u-t
(cat:cat-init) (cat:cat-init)
(let ((c (cat:ls-hat-u-t (cat:deltab))) (let ((c (cat:ls-hat-u-t (cat:deltab)))
allp allp-degr gnrt) allp allp-degr gnrt)
(dotimes (i 10) (print (random-allp 5))) (dotimes (i 10)
(setf allp (random-allp 3)) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 4 (setf gnrt (cat:tnpr allp-degr allp 4
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
(cat:? c (+ 4 allp-degr) gnrt) (unless (>= allp-degr 11)
(cat:? c *) (print (cat:? c (+ 4 allp-degr) gnrt))
(dotimes (i 10) (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt))))))
(let ((allp (random-allp 3))) (dotimes (i 20)
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (let ((allp (random-allp 3)))
(setf gnrt (cat:tnpr allp-degr allp 4 (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (setf gnrt (cat:tnpr allp-degr allp 5
(unless (>= allp-degr 11) (cat:tnpr 3 15 2 (cat:loop3 0 15 2))))
(print (cat:? c (+ 4 allp-degr) gnrt)) (unless (>= allp-degr 10)
(print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) (print (cat:? c (+ 5 allp-degr) gnrt))
(dotimes (i 20) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))
(let ((allp (random-allp 3))) (dotimes (i 20)
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (let ((allp (random-allp 3)))
(setf gnrt (cat:tnpr allp-degr allp 5 (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) (setf gnrt (cat:tnpr allp-degr allp 5
(unless (>= allp-degr 10) (cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(print (cat:? c (+ 5 allp-degr) gnrt)) (unless (>= allp-degr 10)
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) (print (cat:? c (+ 5 allp-degr) gnrt))
(dotimes (i 20) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
|#
#|
(test ls-left-hmeq-hat (test ls-left-hmeq-hat
(cat:cat-init) (cat:cat-init)
(let ((c (cat:ls-left-hmeq-hat (cat:deltab))) (let ((c (cat:ls-left-hmeq-hat (cat:deltab)))
allp allp-degr gnrt) allp allp-degr gnrt)
(dotimes (i 10) (print (random-allp 5))) (dotimes (i 10)
(setf allp (random-allp 3)) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2 (setf gnrt (cat:tnpr allp-degr allp 4
(cat:loop3 0 15 2)))) (cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
(cat:? c (+ 4 allp-degr) gnrt) (unless (>= allp-degr 11)
(cat:? c (cat:? c (+ 4 allp-degr) gnrt)) (print (cat:? c (+ 4 allp-degr) gnrt))
(dotimes (i 10) (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt))))))
(let ((allp (random-allp 3))) (dotimes (i 20)
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (let ((allp (random-allp 3)))
(setf gnrt (cat:tnpr allp-degr allp 4 (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (setf gnrt (cat:tnpr allp-degr allp 5
(unless (>= allp-degr 11) (cat:tnpr 3 15 2 (cat:loop3 0 15 2))))
(print (cat:? c (+ 4 allp-degr) gnrt)) (unless (>= allp-degr 10)
(print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) (print (cat:? c (+ 5 allp-degr) gnrt))
(dotimes (i 20) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))
(let ((allp (random-allp 3))) (dotimes (i 20)
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (let ((allp (random-allp 3)))
(setf gnrt (cat:tnpr allp-degr allp 5 (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) (setf gnrt (cat:tnpr allp-degr allp 5
(unless (>= allp-degr 10) (cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(print (cat:? c (+ 5 allp-degr) gnrt)) (unless (>= allp-degr 10)
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) (print (cat:? c (+ 5 allp-degr) gnrt))
(dotimes (i 20) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
|#
(test ls-pre-left-hmeq-left-reduction-intr-f (test ls-pre-left-hmeq-left-reduction-intr-f
(cat:ls-pre-left-hmeq-left-reduction-intr-f (cat:ls-pre-left-hmeq-left-reduction-intr-f
(cat:cmbn 6 100 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'c)) (cat:cmbn 6 100 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'c))
50 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'cc)) 50 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'cc))
10 (cat:tnpr 0 'a 6 (cat:tnpr 2 'b 4 'c)) 10 (cat:tnpr 0 'a 6 (cat:tnpr 2 'b 4 'c))
1 (cat:tnpr 2 'a 4 (cat:tnpr 2 'b 2 'cc))))) 1 (cat:tnpr 2 'a 4 (cat:tnpr 2 'b 2 'cc)))))
(test ls-left-hmeq-left-reduction-g-intr (test ls-left-hmeq-left-reduction-g-intr
(let ((r (cat:ls-left-hmeq-left-reduction-g-intr '*))) (let ((r (cat:ls-left-hmeq-left-reduction-g-intr '*)))
(funcall r (cat:cmbn 3 4 'loop)))) (funcall r (cat:cmbn 3 4 'loop))))
(test ls-pre-left-hmeq-left-reduction-h-intr (test ls-pre-left-hmeq-left-reduction-h-intr
(cat:cat-init) (cat:cat-init)
(let ((r (cat:ls-pre-left-hmeq-left-reduction-h-intr (cat:deltab)))) (let ((r (cat:ls-pre-left-hmeq-left-reduction-h-intr (cat:deltab))))
(setf cat:*tnpr-with-degrees* t) (setf cat:*tnpr-with-degrees* t)
(funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b) (funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b)
7 (cat:tnpr 5 'c 2 'd)) 7 (cat:tnpr 5 'c 2 'd))
1 (cat:tnpr 7 (cat:allp 2 'a 5 'b) 1 (cat:tnpr 7 (cat:allp 2 'a 5 'b)
3 (cat:tnpr 0 '* 3 'c)) 3 (cat:tnpr 0 '* 3 'c))
10 (cat:tnpr 8 (cat:allp 4 'aa 4 'bb) 10 (cat:tnpr 8 (cat:allp 4 'aa 4 'bb)
2 (cat:tnpr 0 '* 2 'cc)))) 2 (cat:tnpr 0 '* 2 'cc))))
(funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b) (funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b)
7 (cat:tnpr 5 'c 2 'd)) 7 (cat:tnpr 5 'c 2 'd))
1 (cat:tnpr 7 (cat:allp 4 'a 3 'b) 1 (cat:tnpr 7 (cat:allp 4 'a 3 'b)
3 (cat:tnpr 0 '* 3 'c)) 3 (cat:tnpr 0 '* 3 'c))
10 (cat:tnpr 8 (cat:allp 3 'aa 5 'bb) 10 (cat:tnpr 8 (cat:allp 3 'aa 5 'bb)
2 (cat:tnpr 0 '* 2 'cc)))) 2 (cat:tnpr 0 '* 2 'cc))))
(setf cat:*tnpr-with-degrees* nil))) (setf cat:*tnpr-with-degrees* nil)))
#| #|
(test ls-pre-left-hmeq-left-reduction (test ls-pre-left-hmeq-left-reduction
(cat:cat-init) (cat:cat-init)
(let* ((rdct (cat:ls-pre-left-hmeq-left-reduction (cat:deltab))) (let* ((rdct (cat:ls-pre-left-hmeq-left-reduction (cat:deltab)))
(allp (random-allp 3)) (allp (random-allp 3))
(allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2 (gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2
(cat:loop3 0 15 2))))) (cat:loop3 0 15 2)))))
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt)) (setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn 2 1 (cat:loop3 0 15 2))) (setf cat:*bc* (cat:cmbn 2 1 (cat:loop3 0 15 2)))
(check-rdct) (check-rdct)
(setf gnrt (cat:tnpr allp-degr allp 4 (setf gnrt (cat:tnpr allp-degr allp 4
(cat:tnpr 0 1 4 (cat:loop3 0 (cat:mask 6) 2)))) (cat:tnpr 0 1 4 (cat:loop3 0 (cat:mask 6) 2))))
(setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt)) (setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt))
(check-rdct) (check-rdct)
(setf cat:*bc* (cat:cmbn 0 1 (cat:bspn (cat:bcc rdct)))) (setf cat:*bc* (cat:cmbn 0 1 (cat:bspn (cat:bcc rdct))))
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc rdct)))) (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc rdct))))
(check-rdct))) (check-rdct)))
|# |#
(defun a (d1 d2 d3) (defun a (d1 d2 d3)
(setf cat:*tc* (cat:cmbn (+ d1 d2 d3) (setf cat:*tc* (cat:cmbn (+ d1 d2 d3)
1 (cat:tnpr 1 (cat:tnpr
d1 (cat:allp d1 (cat:mask (+ d1 2))) d1 (cat:allp d1 (cat:mask (+ d1 2)))
(+ d2 d3) (+ d2 d3)
(cat:tnpr d2 (cat:mask (1+ d2)) (cat:tnpr d2 (cat:mask (1+ d2))
d3 (cat:loop3 d3 (cat:loop3
0 (cat:mask (+ d3 2)) 1)))) 0 (cat:mask (+ d3 2)) 1))))
cat:*bc* (cat:cmbn d3 1 (cat:loop3 0 (cat:mask (+ d3 2)) -1))) cat:*bc* (cat:cmbn d3 1 (cat:loop3 0 (cat:mask (+ d3 2)) -1)))
(check-rdct)) (check-rdct))
(test ls-left-hmeq-left-reduction (test ls-left-hmeq-left-reduction
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:ls-left-hmeq-left-reduction (cat:deltab2)))) (let ((rdct (cat:ls-left-hmeq-left-reduction (cat:deltab2))))
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
#| #|
(a 1 0 1) (a 1 0 1)
(a 1 1 1) ;; error because 3 does not exist in deltab2 (a 1 1 1) ;; error because 3 does not exist in deltab2
(a 1 2 1) (a 1 2 1)
(a 2 2 1) (a 2 2 1)
|# |#
) )
) )
@ -203,86 +178,86 @@
(test ls-pre-left-hmeq-right-reduction-intr-g (test ls-pre-left-hmeq-right-reduction-intr-g
(let ((r (cat:ls-pre-left-hmeq-right-reduction-intr-g '*))) (let ((r (cat:ls-pre-left-hmeq-right-reduction-intr-g '*)))
(funcall r (cat:cmbn 3 4 'a)))) (funcall r (cat:cmbn 3 4 'a))))
(test ls-pre-left-hmeq-right-reduction (test ls-pre-left-hmeq-right-reduction
(cat:cat-init) (cat:cat-init)
(let ((r (cat:ls-pre-left-hmeq-right-reduction (cat:deltab2)))) (let ((r (cat:ls-pre-left-hmeq-right-reduction (cat:deltab2))))
(cat:pre-check-rdct r) (cat:pre-check-rdct r)
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc r)))) (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc r))))
(setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r)))) (setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r))))
(check-rdct) (check-rdct)
#| #|
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5)) 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5))
0 (cat:tnpr 0 1 0 cat:+null-loop+)))) 0 (cat:tnpr 0 1 0 cat:+null-loop+))))
(setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15))) (setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15)))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15)
3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2))))) 3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2)))))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
6 1 (cat:tnpr 6 1 (cat:tnpr
3 (cat:allp 1 7 2 15) 3 (cat:allp 1 7 2 15)
3 (cat:tnpr 0 1 3 3 (cat:tnpr 0 1 3
(cat:loop3 0 (cat:mask 5) 2))))) (cat:loop3 0 (cat:mask 5) 2)))))
(check-rdct) (check-rdct)
|# |#
)) ))
(test ls-left-hmeq-right-reduction (test ls-left-hmeq-right-reduction
(cat:cat-init) (cat:cat-init)
(let ((r (cat:ls-left-hmeq-right-reduction (cat:deltab2)))) (let ((r (cat:ls-left-hmeq-right-reduction (cat:deltab2))))
(cat:pre-check-rdct r) (cat:pre-check-rdct r)
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc r)))) (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc r))))
(setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r)))) (setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r))))
(check-rdct) (check-rdct)
#| #|
(setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5)) (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5))
0 (cat:tnpr 0 1 0 0 (cat:tnpr 0 1 0
cat:+null-loop+)))) cat:+null-loop+))))
(setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15))) (setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15)))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15)
3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2))))) 3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2)))))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15)
3 (cat:tnpr 0 1 3 3 (cat:tnpr 0 1 3
(cat:loop3 0 (mask 5) 2))))) (cat:loop3 0 (mask 5) 2)))))
(check-rdct) (check-rdct)
|# |#
)) ))
#| #|
(test ls-left-hmeq (test ls-left-hmeq
(cat:cat-init) (cat:cat-init)
(let* ((h (cat:ls-left-hmeq (cat:deltab2))) (let* ((h (cat:ls-left-hmeq (cat:deltab2)))
(loop (cat:loop3 0 (cat:mask 5) 2)) (loop (cat:loop3 0 (cat:mask 5) 2))
(allp (cat:allp 2 (cat:mask 4) 3 (cat:mask 5))) (allp (cat:allp 2 (cat:mask 4) 3 (cat:mask 5)))
x) x)
(setf x (cat:lg h 3 loop)) (setf x (cat:lg h 3 loop))
(setf x (cat:rf h x)) (setf x (cat:rf h x))
(setf x (cat:rg h x)) (setf x (cat:rg h x))
(setf x (cat:lf h x)) (setf x (cat:lf h x))
(setf x (cat:rg h 5 allp)) (setf x (cat:rg h 5 allp))
(setf x (cat:lf h x)) (setf x (cat:lf h x))
(setf x (cat:lg h x)) (setf x (cat:lg h x))
(setf x (cat:rf h x)) ;; = allp, but why ? (setf x (cat:rf h x)) ;; = allp, but why ?
)) ))
|# |#
(test loop-space (test loop-space
(cat:cat-init) (cat:cat-init)
(let ((l (cat:loop-space (cat:sphere 2))) (let ((l (cat:loop-space (cat:sphere 2)))
(oos3 (cat:loop-space (cat:loop-space (cat:sphere 3)))) (oos3 (cat:loop-space (cat:loop-space (cat:sphere 3))))
(ooos4 (cat:loop-space (cat:loop-space (cat:loop-space (ooos4 (cat:loop-space (cat:loop-space (cat:loop-space
(cat:sphere 4)))))) (cat:sphere 4))))))
(cat:homology l 6) (cat:homology l 6)
(cat:homology oos3 3) (cat:homology oos3 3)
(cat:homology ooos4 2))) (cat:homology ooos4 2)))