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",
" 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",
" function is BCC1.\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",
"\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",
"\n",
"5. H, an object of type MORPHISM representing the morphism h. Its reader\n",
" function is H1.\n",
"5. H, an object of type MORPHISM representing the morphism of graded modules h.\n",
" Its reader function is H1.\n",
"\n",
"9. IDNM, an integer, a system-generated identifier for this object. Its reader\n",
" function is IDNM.\n",
"\n",
"10. ORGN, a list containg a comment indicating the origin of the object. The\n",
" should be unique (per session), since it is used in the implementation for\n",
" caching purposes. Its reader function is ORGN.\n",
"10. ORGN, a list containg a comment indicating the origin of the object.\n",
" This comment should be unique for a Kenzo session (between calls of\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",
"follows:\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",
":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",
":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",
":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",
@ -1214,7 +1218,7 @@
"cell_type": "markdown",
"metadata": {},
"source": [
"## 2.6 Construction of abicone from 2 reductions\n",
"## 2.6 Construction of a bicone from 2 reductions\n",
"#### Example"
]
},
@ -2173,7 +2177,7 @@
},
{
"cell_type": "code",
"execution_count": 64,
"execution_count": 65,
"metadata": {
"collapsed": false
},
@ -2253,7 +2257,7 @@
"NIL"
]
},
"execution_count": 64,
"execution_count": 65,
"metadata": {},
"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
:description "A simple regression test suite for Kenzo"
:serial t
:version "0.1.0"
:author "Francis Sergeraert <Francis.Sergeraert@ujf-grenoble.fr>"
:license "GPLv3"
:depends-on (:kenzo :fiveam)
:pathname #P"test/"
:components ((:file "package")
(:file "common")
;; === test files ===
(:file "bar-test")
(:file "bicones-test")
(:file "cartesian-products-test")
(:file "ccn")
(:file "chain-complexes-test")
(:file "chcm-elementary-op-test")
(:file "circle")
(:file "cl-space-efhm-test")
(:file "classifying-spaces-test")
(:file "cobar-test")
(:file "combinations-test")
(:file "cones-test")
(:file "cs-twisted-products-test")
(:file "delta-test")
(:file "diabolo")
(:file "disk-pasting-test")
(:file "eilenberg-zilber-test")
(:file "effective-homology-test")
(:file "fibrations-test")
(:file "homology-groups-test")
(:file "k-pi-n-test")
(:file "kan-test")
(:file "loop-spaces-test")
(:file "lp-space-efhm-test")
(:file "ls-twisted-products-test")
(:file "macros-test")
(:file "searching-homology-test")
(:file "serre-test")
(:file "simplicial-groups-test")
(:file "simplicial-mrphs-test")
(:file "simplicial-sets-test")
(:file "smith-test")
(:file "special-smsts-test")
(:file "suspensions-test")
(:file "tensor-products-test")
(:file "various-test")
(:file "whitehead-test")
))
:description "A simple regression test suite for Kenzo"
:serial t
:version "0.1.0"
:author "Francis Sergeraert <Francis.Sergeraert@ujf-grenoble.fr>"
:license "GPLv3"
:depends-on (:kenzo :fiveam)
:pathname #P"test/"
:components ((:file "package")
(:file "common")
;; === test files ===
(:file "bar-test")
(:file "bicones-test")
(:file "cartesian-products-test")
(:file "ccn")
(:file "chain-complexes-test")
(:file "chcm-elementary-op-test")
(:file "circle")
(:file "cl-space-efhm-test")
(:file "classifying-spaces-test")
(:file "cobar-test")
(:file "combinations-test")
(:file "cones-test")
(:file "cs-twisted-products-test")
(:file "delta-test")
(:file "diabolo")
(:file "disk-pasting-test")
(:file "eilenberg-zilber-test")
(:file "effective-homology-test")
(:file "fibrations-test")
(:file "homology-groups-test")
(:file "k-pi-n-test")
(:file "kan-test")
(:file "loop-spaces-test")
(:file "lp-space-efhm-test")
(:file "ls-twisted-products-test")
(:file "macros-test")
(:file "searching-homology-test")
(:file "serre-test")
(:file "simplicial-groups-test")
(:file "simplicial-mrphs-test")
(:file "simplicial-sets-test")
(:file "smith-test")
(:file "special-smsts-test")
(:file "suspensions-test")
(:file "tensor-products-test")
(:file "various-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)))
(DEFCONSTANT +SOURCE-EXTENSION+
#+(or allegro clisp lispworks) "cl"
#+(or ccl ecl sbcl) "lisp"
#+(or allegro lispworks) "cl"
#+(or clisp ccl ecl sbcl) "lisp"
#-(or allegro ccl clisp ecl lispworks sbcl)
(error "Not an Allegro or CCL or CLisp or LispWorks or SBCL environment."))
@ -79,6 +79,8 @@
(DEFVAR *CMBN-CONTROL*)
(SETF *CMBN-CONTROL* T)
#+SBCL (DECLAIM (SB-EXT:MUFFLE-CONDITIONS style-warning compiler-note))
(DEFUN COMPILE-FILES ()
(format t "~%*CMBN-CONTROL* = ~A~2%" *cmbn-control*)
(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.
------------------------------------------------------------------------------"
(mapc #'(lambda (symbol)
(declare (type (or string symbol) symbol))
(let ((length (length (eval symbol))))
(declare (fixnum length))
(setf symbol (symbol-name symbol))
(setf symbol (subseq symbol 1 (- (length symbol) 6)))
(format t "~%~6D ~As" length symbol)))
*list-list*)
(declare (type (or string symbol) symbol))
(let ((length (length (eval symbol))))
(declare (fixnum length))
(setf symbol (symbol-name symbol))
(setf symbol (subseq symbol 1 (- (length symbol) 6)))
(format t "~%~6D ~As" length symbol)))
*list-list*)
(done))
@ -48,12 +48,12 @@ Args: ()
Return a string representation of a user created objects.
------------------------------------------------------------------------------"
(let ((object-list
(sort (delete-duplicates
(mapcan #'(lambda (symbol)
(copy-list (eval symbol)))
*list-list*)
:test #'eq)
#'< :key #'idnm)))
(sort (delete-duplicates
(mapcan #'(lambda (symbol)
(copy-list (eval symbol)))
*list-list*)
:test #'eq)
#'< :key #'idnm)))
(declare (list object-list))
(dolist (item object-list)
(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*)
(let ((found (find idnm (eval list) :key #'idnm)))
(when found
(format t "~%Object: ~A
(format t "~%Object: ~A
~3TOrigin: ~A~2%" found (orgn found))
(return-from kd (values))))))
(return-from kd (values))))))
(DEFUN K (idnm)
@ -86,7 +86,7 @@ Returns the IDNM-th Kenzo object.
(dolist (list *list-list*)
(let ((found (find idnm (eval list) :key #'idnm)))
(when found
(return-from k found)))))
(return-from k found)))))
(DEFUN KD2 (idnm)
@ -104,16 +104,16 @@ the list of object numbers.
(return-from kd2 nil))
(setf k-list (list k-list))
(do ((idnm (1- idnm) (1- idnm)))
((zerop idnm))
((zerop idnm))
(declare (fixnum idnm))
(let ((found (find-if
#'(lambda (item)
(declare (type (or chain-complex morphism) item))
(member (k idnm) (orgn item)))
k-list)))
(declare (type (or null chain-complex morphism) found))
(when found
(push (k idnm) k-list))))
#'(lambda (item)
(declare (type (or chain-complex morphism) item))
(member (k idnm) (orgn item)))
k-list)))
(declare (type (or null chain-complex morphism) found))
(when found
(push (k 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)
(the chain-complex
(progn
(format stream "[K~D Chain-Complex]" (idnm chcm))
chcm)))
(format stream "[K~D Chain-Complex]" (idnm chcm))
chcm)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t))
@ -149,8 +149,8 @@ identifier IDNUM or NIL, if it doesn't exist.
~3TVALUE-> ~A
~4TCLNM-> ~6D
~4TRNTM-> ~11,3F"
(result-gnrt result) (result-value result)
(result-clnm result) (result-rntm result))
(result-gnrt result) (result-value result)
(result-clnm result) (result-rntm result))
result)
@ -193,12 +193,12 @@ identifier IDNUM or NIL, if it doesn't exist.
(DEFMETHOD PRINT-OBJECT ((mrph morphism) stream)
(the morphism
(progn
(if (eq (first (orgn (trgt mrph))) 'z-chcm)
(format stream "[K~D Cohomology-Class on K~D of degree ~D]"
(idnm mrph) (idnm (sorc mrph)) (- (degr mrph)))
(format stream "[K~D Morphism (degree ~D): K~D -> K~D]"
(idnm mrph) (degr mrph)
(idnm (sorc mrph)) (idnm (trgt mrph))))
(if (eq (first (orgn (trgt mrph))) 'z-chcm)
(format stream "[K~D Cohomology-Class on K~D of degree ~D]"
(idnm mrph) (idnm (sorc mrph)) (- (degr mrph)))
(format stream "[K~D Morphism (degree ~D): K~D -> K~D]"
(idnm mrph) (degr mrph)
(idnm (sorc mrph)) (idnm (trgt mrph))))
mrph)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t))
@ -239,10 +239,12 @@ follows:
of the differential homomorphism, either by generator or by
combination. The default is :GNRT
:ORGN ORGN, a list containing a relevant and carefully chosen comment about
the origin of the chain complex. This comment should be unique
for a Kenzo session (between calls of CAT-INIT), as it is used
for caching purposes.
:ORGN ORGN, a list which is the copy of a Lisp statement, in principle the
statement which was at the origin of the creation of this Kenzo
object. 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.
Use this function instead of creating instances via the standard constructor
MAKE-INSTANCE.
@ -250,25 +252,25 @@ MAKE-INSTANCE.
(the chain-complex
(progn
(let ((already (find orgn *chcm-list* :test #'equal :key #'orgn)))
(declare (type (or chain-complex null) already))
(when already
(return-from build-chcm already)))
(declare (type (or chain-complex null) already))
(when already
(return-from build-chcm already)))
(unless basis
(setf basis :locally-effective))
(setf basis :locally-effective))
(let ((chcm (make-instance 'chain-complex
:cmpr cmpr
:basis basis
:bsgn bsgn
:orgn orgn)))
(declare (type chain-complex chcm))
(setf (slot-value chcm 'dffr)
(build-mrph
:sorc chcm :trgt chcm :degr -1
:intr intr-dffr :strt strt
:orgn `(dffr ,chcm)))
(setf (slot-value chcm 'grmd) chcm)
(push chcm *chcm-list*)
chcm))))
:cmpr cmpr
:basis basis
:bsgn bsgn
:orgn orgn)))
(declare (type chain-complex chcm))
(setf (slot-value chcm 'dffr)
(build-mrph
:sorc chcm :trgt chcm :degr -1
:intr intr-dffr :strt strt
:orgn `(dffr ,chcm)))
(setf (slot-value chcm 'grmd) chcm)
(push chcm *chcm-list*)
chcm))))
(DEFUN BASIS2 (object n) ;;;
@ -279,7 +281,7 @@ MAKE-INSTANCE.
(with-slots (basis) object
(declare (type basis 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))))
@ -308,10 +310,12 @@ follows:
of the differential homomorphism, either by generator or by
combination. The default is :GNRT
:ORGN ORGN, a list containing a relevant and carefully chosen comment about
the origin of the chain complex. This comment should be unique
for a Kenzo session (between calls of CAT-INIT), as it is used
for caching purposes.
:ORGN ORGN, a list which is the copy of a Lisp statement, in principle the
statement which was at the origin of the creation of this Kenzo
object. 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.
Use this function instead of creating instances via the standard constructor
MAKE-INSTANCE.
@ -319,63 +323,63 @@ MAKE-INSTANCE.
(the morphism
(progn
(let ((already (find orgn *mrph-list* :test #'equal :key #'orgn)))
(declare (type (or morphism null) already))
(when already
(return-from build-mrph already)))
(declare (type (or morphism null) already))
(when already
(return-from build-mrph already)))
(let ((mrph (make-instance 'morphism
:sorc sorc :trgt trgt :degr degr
:intr intr :strt strt
:orgn orgn)))
(declare (type morphism mrph))
(setf (slot-value mrph 'rslts)
(ecase strt
(:gnrt (map 'simple-vector
:sorc sorc :trgt trgt :degr degr
:intr intr :strt strt
:orgn orgn)))
(declare (type morphism mrph))
(setf (slot-value mrph 'rslts)
(ecase strt
(:gnrt (map 'simple-vector
;; (vector (vector result))
#'(lambda (dummy)
(declare (ignore dummy))
(make-array 0
:adjustable t
:fill-pointer 0))
(declare (ignore dummy))
(make-array 0
:adjustable t
:fill-pointer 0))
(make-list +maximal-dimension+)))
(:cmbn (make-array 0))))
(push mrph *mrph-list*)
mrph))))
(:cmbn (make-array 0))))
(push mrph *mrph-list*)
mrph))))
;;; FUNCTIONS
(DEFUN NRESULTS ()
(the fixnum
(let ((nrslts 0))
(declare (fixnum nrslts))
(dolist (item *mrph-list*)
(declare (type morphism item))
(when (eq :gnrt (strt item))
(map nil
#'(lambda (drslt)
(declare (vector drslt))
(incf nrslts (length drslt)))
(rslts item))))
nrslts)))
(declare (fixnum nrslts))
(dolist (item *mrph-list*)
(declare (type morphism item))
(when (eq :gnrt (strt item))
(map nil
#'(lambda (drslt)
(declare (vector drslt))
(incf nrslts (length drslt)))
(rslts item))))
nrslts)))
(DEFUN TIME-LIST ()
(the list
(let ((time-list +empty-list+))
(declare (list time-list))
(dolist (item *mrph-list*)
(declare (type morphism item))
(when (eq :gnrt (strt item))
(map nil #'(lambda (drslt)
(declare (vector drslt))
(map nil #'(lambda (rslt)
(declare (type result rslt))
(let ((rntm (result-rntm rslt)))
(declare (single-float rntm))
(when (plusp rntm)
(push rntm time-list))))
drslt))
(rslts item))))
(sort time-list #'>))))
(declare (list time-list))
(dolist (item *mrph-list*)
(declare (type morphism item))
(when (eq :gnrt (strt item))
(map nil #'(lambda (drslt)
(declare (vector drslt))
(map nil #'(lambda (rslt)
(declare (type result rslt))
(let ((rntm (result-rntm rslt)))
(declare (single-float rntm))
(when (plusp rntm)
(push rntm time-list))))
drslt))
(rslts item))))
(sort time-list #'>))))
(DEFUN CLEAN-RESULTS (&optional (results-coef *results-coef*))
@ -384,35 +388,35 @@ MAKE-INSTANCE.
(special *results-coef* *results-cmlt-tm* *results-n* *results-verbose*))
(the (values )
(let ((cut (* results-coef (/ *results-cmlt-tm* *results-n*))))
(declare (single-float cut))
(setf *results-n* 0 *results-cmlt-tm* 0.0)
(dolist (item *mrph-list*)
(declare (type morphism item))
(when (eq :gnrt (strt item))
(let ((rslts (rslts item)))
(declare (vector rslts))
(dotimes (i +maximal-dimension+)
(declare (fixnum i))
(let ((rslts-i (aref rslts i))
(output (make-array 0 :adjustable t :fill-pointer 0)))
(declare (vector rslts-i output))
(map nil
#'(lambda (rslt)
(declare (type result rslt))
(let ((rntm (result-rntm rslt)))
(declare (single-float rntm))
(when (> rntm cut)
(incf *results-n*)
(incf *results-cmlt-tm* rntm)
(vector-push-extend rslt output))))
rslts-i)
(setf (aref rslts i) output))))))
(when *results-verbose*
(format t "~%*CR* -- Cut = ~A -- N = ~A" cut *results-n*)))))
(declare (single-float cut))
(setf *results-n* 0 *results-cmlt-tm* 0.0)
(dolist (item *mrph-list*)
(declare (type morphism item))
(when (eq :gnrt (strt item))
(let ((rslts (rslts item)))
(declare (vector rslts))
(dotimes (i +maximal-dimension+)
(declare (fixnum i))
(let ((rslts-i (aref rslts i))
(output (make-array 0 :adjustable t :fill-pointer 0)))
(declare (vector rslts-i output))
(map nil
#'(lambda (rslt)
(declare (type result rslt))
(let ((rntm (result-rntm rslt)))
(declare (single-float rntm))
(when (> rntm cut)
(incf *results-n*)
(incf *results-cmlt-tm* rntm)
(vector-push-extend rslt output))))
rslts-i)
(setf (aref rslts i) output))))))
(when *results-verbose*
(format t "~%*CR* -- Cut = ~A -- N = ~A" cut *results-n*)))))
(DEFUN MRPH-GNRT (cmpr2 intr degr gnrt memory
&optional (left -1) (right (fill-pointer memory)))
&optional (left -1) (right (fill-pointer memory)))
(declare
(type intr-mrph intr)
;; (function (fixnum gnrt) cmbn)
@ -427,47 +431,47 @@ MAKE-INSTANCE.
;; cmbn = image of the generator
;; fixnum = index "exact" or just "lower" of the maybe stored result
(loop
(when (= right (1+ left)) ; the result for gnrt is not available
(push (get-internal-run-time) *start-stack*)
(let ((value (funcall intr degr gnrt))
(runtime (- (get-internal-run-time) (pop *start-stack*))))
(declare
(type cmbn value)
(integer runtime))
(if (> runtime +too-much-time+)
;; the condition deciding whether
;; storing must happen
(let ((old-length (vector-push-extend nil memory)))
(declare (fixnum old-length))
(replace memory memory
:start1 (1+ right) :end1 (1+ old-length)
:start2 right :end2 old-length)
(setf (aref memory right)
(make-result
:gnrt gnrt :value value :clnm 1
:rntm (let ((rntm
(float
(/ runtime
internal-time-units-per-second))))
(declare (single-float rntm))
(incf *results-cmlt-tm* rntm)
rntm)))
(mapl #'(lambda (mark)
(declare (cons mark))
(incf (car mark) runtime))
*start-stack*)
(when (> (incf *results-n*) *results-max*)
(clean-results))
(return (values value right)))
(return (values value left)))))
(let ((middle (truncate (+ right left) 2)))
(when (= right (1+ left)) ; the result for gnrt is not available
(push (get-internal-run-time) *start-stack*)
(let ((value (funcall intr degr gnrt))
(runtime (- (get-internal-run-time) (pop *start-stack*))))
(declare
(type cmbn value)
(integer runtime))
(if (> runtime +too-much-time+)
;; the condition deciding whether
;; storing must happen
(let ((old-length (vector-push-extend nil memory)))
(declare (fixnum old-length))
(replace memory memory
:start1 (1+ right) :end1 (1+ old-length)
:start2 right :end2 old-length)
(setf (aref memory right)
(make-result
:gnrt gnrt :value value :clnm 1
:rntm (let ((rntm
(float
(/ runtime
internal-time-units-per-second))))
(declare (single-float rntm))
(incf *results-cmlt-tm* rntm)
rntm)))
(mapl #'(lambda (mark)
(declare (cons mark))
(incf (car mark) runtime))
*start-stack*)
(when (> (incf *results-n*) *results-max*)
(clean-results))
(return (values value right)))
(return (values value left)))))
(let ((middle (truncate (+ right left) 2)))
(declare (fixnum middle))
(ecase (funcall cmpr2 gnrt (result-gnrt (aref memory middle)))
(:equal (let ((rslt (aref memory middle)))
(declare (type result rslt))
(incf (result-clnm rslt))
(return (values (result-value rslt) middle))))
(:less (setf right middle))
(:equal (let ((rslt (aref memory middle)))
(declare (type result rslt))
(incf (result-clnm rslt))
(return (values (result-value rslt) middle))))
(:less (setf right middle))
(:greater (setf left middle)))))))
@ -481,17 +485,17 @@ MAKE-INSTANCE.
;; (vector result)
(the cmbn
(with-cmbn (degr list) cmbn
(let ((n-cmbn-list +empty-list+))
(declare (list n-cmbn-list))
(do ((mark list (cdr mark))
(left -1))
((endp mark))
(declare (list mark))
(multiple-value-bind (rslt new-left)
(mrph-gnrt scmpr2 intr degr (-gnrt mark) memory left)
(setf left new-left)
(push (cons (-cffc mark) rslt) n-cmbn-list)))
(cmbn-cmbn tcmpr2 n-cmbn-list)))))
(let ((n-cmbn-list +empty-list+))
(declare (list n-cmbn-list))
(do ((mark list (cdr mark))
(left -1))
((endp mark))
(declare (list mark))
(multiple-value-bind (rslt new-left)
(mrph-gnrt scmpr2 intr degr (-gnrt mark) memory left)
(setf left new-left)
(push (cons (-cffc mark) rslt) n-cmbn-list)))
(cmbn-cmbn tcmpr2 n-cmbn-list)))))
(DEFUN DO-CONTROL (cmpr cmbn)
(declare
@ -501,14 +505,14 @@ MAKE-INSTANCE.
(let ((list (cmbn-list cmbn)))
(declare (list list))
(do ((mark1 (rest list) (cdr mark1))
(mark2 list mark1))
((endp mark1))
(declare (list mark1 mark2))
(unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1)))
(setf *wrong-cmbn* cmbn)
(error "In the combination located by *WRONG-CMBN*, the generators:~@
(mark2 list mark1))
((endp mark1))
(declare (list mark1 mark2))
(unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1)))
(setf *wrong-cmbn* cmbn)
(error "In the combination located by *WRONG-CMBN*, the generators:~@
~A and ~A are in a wrong order." (cdar mark2)
(cdar mark1))))))
(cdar mark1))))))
cmbn)
#|
@ -517,9 +521,9 @@ MAKE-INSTANCE.
(DEFUN PROFILER-INIT ()
(mapc #'(lambda (mrph)
(declare (type morphism mrph))
(setf (wrtm mrph) 0))
*mrph-list*))
(declare (type morphism mrph))
(setf (wrtm mrph) 0))
*mrph-list*))
(DEFUN PROFILER-ON ()
(push (get-internal-run-time) *profiler-stack*))
@ -527,12 +531,12 @@ MAKE-INSTANCE.
(DEFUN PROFILER-OFF (mrph)
(declare (type morphism mrph))
(let ((time-spent
(- (get-internal-run-time) (pop *profiler-stack*))))
(- (get-internal-run-time) (pop *profiler-stack*))))
(declare (integer time-spent))
(mapl #'(lambda (mark)
(declare (cons mark))
(incf (car mark) time-spent))
*profiler-stack*)
(declare (cons mark))
(incf (car mark) time-spent))
*profiler-stack*)
(incf (wrtm mrph) time-spent)))
|#
@ -544,35 +548,35 @@ MAKE-INSTANCE.
(type gnrt gnrt))
(the cmbn
(progn
;; (profiler-on)
;; (profiler-on)
(when (and *future-display*
(> (get-internal-run-time) *future-display*))
(format t "~%GNRT-?
(format t "~%GNRT-?
~3T~A ORGN = ~A
~3TDEGR = ~D
~3TGNRT = ~A"
mrph (orgn mrph) degr gnrt)
(setf *future-display* (+ (get-internal-run-time) *time-interval*)))
mrph (orgn mrph) degr gnrt)
(setf *future-display* (+ (get-internal-run-time) *time-interval*)))
(with-slots (sorc (mdegr degr) intr strt ?-clnm) mrph
(declare
(type chain-complex sorc)
(fixnum mdegr ?-clnm)
(type intr-mrph intr)
(type strt strt))
(with-slots ((scmpr cmpr)) sorc
(declare (type cmprf scmpr))
(control (slot-value (slot-value mrph 'trgt) 'cmpr)
(progn
(incf ?-clnm)
(prog1
(ecase strt
(:gnrt
(mrph-gnrt scmpr intr
degr gnrt (svref (rslts mrph) degr)))
(:cmbn
(funcall intr (term-cmbn degr 1 gnrt))))
;; (profiler-off mrph)
))))))))
(declare
(type chain-complex sorc)
(fixnum mdegr ?-clnm)
(type intr-mrph intr)
(type strt strt))
(with-slots ((scmpr cmpr)) sorc
(declare (type cmprf scmpr))
(control (slot-value (slot-value mrph 'trgt) 'cmpr)
(progn
(incf ?-clnm)
(prog1
(ecase strt
(:gnrt
(mrph-gnrt scmpr intr
degr gnrt (svref (rslts mrph) degr)))
(:cmbn
(funcall intr (term-cmbn degr 1 gnrt))))
;; (profiler-off mrph)
))))))))
(DEFUN CMBN-? (mrph cmbn)
@ -581,35 +585,35 @@ MAKE-INSTANCE.
(type cmbn cmbn))
(the cmbn
(progn
;; (profiler-on)
;; (profiler-on)
(when (and *future-display*
(> (get-internal-run-time) *future-display*))
(format t "~%CMBN-?
(format t "~%CMBN-?
~3T~A ORGN = ~A
~3TCMBN = ~A"
mrph (orgn mrph) cmbn)
(setf *future-display* (+ (get-internal-run-time) *time-interval*)))
mrph (orgn mrph) cmbn)
(setf *future-display* (+ (get-internal-run-time) *time-interval*)))
(with-slots (sorc trgt degr intr strt ???-clnm) mrph
(declare
(type chain-complex sorc trgt)
(fixnum degr ???-clnm)
(type intr-mrph intr)
(type strt strt))
(with-slots ((scmpr cmpr)) sorc
(declare (type cmprf scmpr))
(with-slots ((tcmpr cmpr)) trgt
(declare (type cmprf tcmpr))
(control tcmpr
(progn
(controln scmpr cmbn)
(incf ???-clnm)
(when (eq strt :cmbn)
(return-from cmbn-? (funcall intr cmbn)))
(prog1
(if (cmbn-zero-p cmbn)
(zero-cmbn (+ (cmbn-degr cmbn) degr))
(mrph-cmbn scmpr tcmpr intr
cmbn (svref (rslts mrph)
(cmbn-degr cmbn))))
;; (profiler-off mrph)
)))))))))
(declare
(type chain-complex sorc trgt)
(fixnum degr ???-clnm)
(type intr-mrph intr)
(type strt strt))
(with-slots ((scmpr cmpr)) sorc
(declare (type cmprf scmpr))
(with-slots ((tcmpr cmpr)) trgt
(declare (type cmprf tcmpr))
(control tcmpr
(progn
(controln scmpr cmbn)
(incf ???-clnm)
(when (eq strt :cmbn)
(return-from cmbn-? (funcall intr cmbn)))
(prog1
(if (cmbn-zero-p cmbn)
(zero-cmbn (+ (cmbn-degr cmbn) degr))
(mrph-cmbn scmpr tcmpr intr
cmbn (svref (rslts mrph)
(cmbn-degr cmbn))))
;; (profiler-off mrph)
)))))))))

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

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

166
src/classes.lisp
View File

@ -45,7 +45,7 @@ internal representation of combinations.
(declare (type any object))
(the boolean
(and (typep object 'fixnum)
(/= 0 object))))
(/= 0 object))))
(DEFTYPE CFFC ()
"------------------------------------------------------------------[type-doc]
@ -90,8 +90,8 @@ A derived type to represent comparison functions.
(declare (type any object))
(the boolean
(and (consp object)
(typep (car object) 'cffc)
(typep (cdr object) 'gnrt))))
(typep (car object) 'cffc)
(typep (cdr object) 'gnrt))))
(DEFTYPE TERM ()
"------------------------------------------------------------------[type-doc]
@ -110,7 +110,7 @@ and whose CDR is of type GNRT.
(declare (type any object))
(the boolean
(and (listp object)
(every #'term-p object))))
(every #'term-p object))))
(DEFTYPE ICMBN () '(satisfies icmbn-p))
@ -141,8 +141,8 @@ the symbol :LOCALLY-EFFECTIVE.
#+allegro
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf redefinition-warnings-saved
excl::*redefinition-warnings*
*redefinition-warnings* nil))
excl::*redefinition-warnings*
*redefinition-warnings* nil))
(DEFCLASS CHAIN-COMPLEX ()
((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
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
function is IDNM.
8. ORGN, a list containg a comment indicating the origin of the object. The
should be unique (per session), since it is used in the implementation for
caching purposes. Its reader function is ORGN.
8. ORGN, a list which is the copy of a Lisp statement, in principle the
statement which was at the origin of the creation of this Kenzo object.
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)
;; ReSuLTS
(rslts :type simple-vector
;; (vector (vector result))
:reader rslts)
;; (vector (vector result))
:reader rslts)
;; IDentification NuMber
(idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
;; 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.
4. INTR, a Lisp function implementing the morphism, taking account of the
strategy STRT. Its reader function is INTR.
4. INTR, a Lisp INTeRnal function implementing the morphism, taking account
of the strategy STRT. Its reader function is INTR.
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
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
function is IDNM.
10. ORGN, a list containg a comment indicating the origin of the object. The
should be unique (per session), since it is used in the implementation for
caching purposes. Its reader function is ORGN.
10. ORGN, a list which is the copy of a Lisp statement, in principle the
statement which was at the origin of the creation of this Kenzo object.
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
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.
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.
5. H, an object of type MORPHISM representing the morphism h. Its reader
function is H1.
5. H, an object of type MORPHISM representing the morphism of graded modules h.
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.
10. ORGN, a list containg a comment indicating the origin of the object. The
should be unique (per session), since it is used in the implementation for
caching purposes. Its reader function is ORGN.
7. ORGN, a list which is the copy of a Lisp statement, in principle the
statement which was at the origin of the creation of this Kenzo object.
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
(idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
;; 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
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf excl::*redefinition-warnings*
redefinition-warnings-saved))
redefinition-warnings-saved))
;;;
;;; HOMOLOGY-GROUPS
@ -365,9 +396,31 @@ The class has 7 slots:
(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)
(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)
@ -379,11 +432,26 @@ The class has 7 slots:
(conx (:type '(member 0 1)))
(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))
(bcnx (:type '(member :bcnb :bcnc :bcnd)))
(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
@ -412,8 +480,8 @@ The class has 7 slots:
(declare (type any object))
(the boolean
(and (consp object)
(typep (car object) 'fixnum) ;; degree *in* the cobar
(typep (cdr object) 'gnrt))))
(typep (car object) 'fixnum) ;; degree *in* the cobar
(typep (cdr object) 'gnrt))))
(DEFTYPE CBGN () '(satisfies cbgn-p))
@ -422,7 +490,7 @@ The class has 7 slots:
(declare (type any object))
(the boolean
(and (listp object)
(every #'cbgn-p object))))
(every #'cbgn-p object))))
(DEFTYPE IALLP () '(satisfies iallp-p))
@ -454,8 +522,8 @@ The class has 7 slots:
(declare (type any object))
(the boolean
(and (consp object)
(typep (car object) 'fixnum) ;; degree *in* the bar
(typep (cdr object) 'gnrt))))
(typep (car object) 'fixnum) ;; degree *in* the bar
(typep (cdr object) 'gnrt))))
(DEFTYPE BRGN () '(satisfies brgn-p))
@ -464,7 +532,7 @@ The class has 7 slots:
(declare (type any object))
(the boolean
(and (listp object)
(every #'brgn-p object))))
(every #'brgn-p object))))
(DEFTYPE IABAR () '(satisfies iabar-p))
@ -476,8 +544,8 @@ The class has 7 slots:
(declare (type any object))
(the boolean
(and (consp object)
(eq :abar (car object))
(typep (cdr object) 'iabar))))
(eq :abar (car object))
(typep (cdr object) 'iabar))))
(DEFTYPE ABAR () '(satisfies abar-p))
|#
@ -508,8 +576,8 @@ The class has 7 slots:
(declare (type any object))
(the boolean
(and (consp object)
(typep (car object) 'dgop)
(typep (cdr object) 'gmsm))))
(typep (car object) 'dgop)
(typep (cdr object) 'gmsm))))
(DEFTYPE IABSM () '(satisfies iabsm-p))
@ -555,8 +623,8 @@ The class has 7 slots:
(declare (type any object))
(the boolean
(and (consp object)
(eq :delt (car object))
(typep (cdr object) 'dgop))))
(eq :delt (car object))
(typep (cdr object) 'dgop))))
(DEFTYPE SOFT-DLOP () '(satisfies soft-dlop-p))
@ -589,7 +657,7 @@ The class has 7 slots:
(declare (type any object))
(the boolean
(and (typep object 'simplicial-mrph)
(= -1 (degr object)))))
(= -1 (degr object)))))
(DEFTYPE FIBRATION ()
'(satisfies fibration-p))
@ -610,7 +678,7 @@ The class has 7 slots:
(declare (type any object))
(the boolean
(typep object '(and fixnum
(not (eql 0))))))
(not (eql 0))))))
(DEFTYPE EXPN () '(satisfies expn-p))
@ -619,8 +687,8 @@ The class has 7 slots:
(declare (type any object))
(the boolean
(and (consp object)
(typep (car object) 'gmsm)
(typep (cdr object) 'expn))))
(typep (car object) 'gmsm)
(typep (cdr object) 'expn))))
(DEFTYPE POWR () '(satisfies powr-p))
@ -629,8 +697,8 @@ The class has 7 slots:
(declare (type any object))
(the boolean
(and (consp object)
(typep (car object) 'dgop)
(typep (cdr object) 'powr))))
(typep (car object) 'dgop)
(typep (cdr object) 'powr))))
(DEFTYPE APOWR () '(satisfies apowr-p))
@ -639,7 +707,7 @@ The class has 7 slots:
(declare (type any object))
(the boolean
(and (listp object)
(every #'apowr-p object))))
(every #'apowr-p object))))
(DEFTYPE ILOOP () '(satisfies iloop-p))
@ -650,7 +718,7 @@ The class has 7 slots:
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :common-lisp) nil))
#+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))
(list (:type 'iloop)))
@ -661,7 +729,7 @@ The class has 7 slots:
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :common-lisp) t))
#+sbcl(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:lock-package :common-lisp))
(sb-ext:lock-package :common-lisp))
#+ccl
(DEFMETHOD make-load-form ((l loop) &optional env)

4
src/combinations.lisp
View File

@ -137,8 +137,8 @@ CMBN
Args: (degr &rest rest)
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.
REST can be of arbitrary even length and can be empty, in which case the
combination is an instance of the null combination of degree DEGR.
REST can be of arbitrary length including NIL, in which case the combination
is an instance of the null combination of degree DEGR.
------------------------------------------------------------------------------"
(the cmbn
(make-cmbn :degr degr

405
src/effective-homology.lisp
View File

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

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

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

10
src/macros.lisp
View File

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

337
test/bar-test.lisp
View File

@ -1,4 +1,3 @@
(in-package :kenzo-test)
(in-suite :kenzo)
@ -11,127 +10,126 @@
(test bar-cmpr
(let ((r (cat:bar-cmpr #'cat:s-cmpr)))
(is (equal :equal (funcall r (cat:abar) (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 3 'b))))
(is (equal :equal (funcall r (cat:abar 3 'a) (cat:abar 3 'a))))))
(is (equal :equal (funcall r (cat:abar) (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 3 'b))))
(is (equal :equal (funcall r (cat:abar 3 'a) (cat:abar 3 'a))))))
(test bar-basis-length
(let ((basis #'(lambda (degr) (list degr))))
(cat:bar-basis-length basis 2 1)
(cat:bar-basis-length basis 2 2)
(cat:bar-basis-length basis 3 1)
(cat:bar-basis-length basis 3 2)
(cat:bar-basis-length basis 4 1)
(cat:bar-basis-length basis 4 2)
(cat:bar-basis-length basis 4 3)
(cat:bar-basis-length basis 4 4)
(cat:bar-basis-length basis 8 1)
(cat:bar-basis-length basis 8 2)
(cat:bar-basis-length basis 8 3)
(cat:bar-basis-length basis 8 4)
(cat:bar-basis-length basis 8 5)
(cat:bar-basis-length basis 8 6)
(cat:bar-basis-length basis 8 11)))
(cat:bar-basis-length basis 2 1)
(cat:bar-basis-length basis 2 2)
(cat:bar-basis-length basis 3 1)
(cat:bar-basis-length basis 3 2)
(cat:bar-basis-length basis 4 1)
(cat:bar-basis-length basis 4 2)
(cat:bar-basis-length basis 4 3)
(cat:bar-basis-length basis 4 4)
(cat:bar-basis-length basis 8 1)
(cat:bar-basis-length basis 8 2)
(cat:bar-basis-length basis 8 3)
(cat:bar-basis-length basis 8 4)
(cat:bar-basis-length basis 8 5)
(cat:bar-basis-length basis 8 6)
(cat:bar-basis-length basis 8 11)))
(test bar-basis
(let* ((basis #'(lambda (degr) (list degr)))
(r (cat:bar-basis basis)))
(funcall r 0)
(funcall r 1)
(funcall r 2)
(dotimes (i 7)
(print (funcall r i)))
(cat:bar-basis :locally-effective)))
(r (cat:bar-basis basis)))
(funcall r 0)
(funcall r 1)
(funcall r 2)
(dotimes (i 7)
(print (funcall r i)))
(cat:bar-basis :locally-effective)))
(test bar-intr-vrtc-dffr
(let* ((d (cat:soft-delta-infinity))
(r (cat:bar-intr-vrtc-dffr (cat:dffr d))))
(funcall r 0 (cat:abar))
(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 2 (cat:d 3) 3 (cat:d 7)))))
(r (cat:bar-intr-vrtc-dffr (cat:dffr d))))
(funcall r 0 (cat:abar))
(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 2 (cat:d 3) 3 (cat:d 7)))))
(defun random-abar1 (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (cat:mask 7)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cat:brgn (1+ dmns) (cat:d gmsm)) rslt))))
(let* ((gmsm (random (cat:mask 6)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cat:brgn (1+ dmns) gmsm) rslt))))
(cat:make-abar :list rslt)))
(test vrtc-bar
(progn
(cat:cat-init)
(let ((v (cat:vrtc-bar (cat:soft-delta-infinity))))
(dotimes (i 10)
(print (random-abar1 5)))
(dotimes (i 10)
(let ((abar (random-abar1 3)))
(print abar)
(print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar))
(print (cat:? v (cat:? v (apply #'+ (mapcar #'car
(cat:abar-list abar)))
abar))))))))
(cat:cat-init)
(let ((v (cat:vrtc-bar (cat:delta-infinity))))
(dotimes (i 10)
(print (random-abar1 5)))
(dotimes (i 10)
(let ((abar (random-abar1 3)))
(print abar)
(print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar))
(print (cat:? v (cat:? v (apply #'+ (mapcar #'car
(cat:abar-list abar)))
abar))))))))
(test bar-intr-hrzn-dffr
(let* ((k (cat:k-z-1))
(r (cat:bar-intr-hrzn-dffr (cat:aprd k))))
(funcall r 0 (cat:abar ))
(funcall r 3 (cat:abar 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 11 (cat:abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3)))))
(r (cat:bar-intr-hrzn-dffr (cat:aprd k))))
(funcall r 0 (cat:abar ))
(funcall r 3 (cat:abar 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 11 (cat:abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3)))))
#|
(test bar-hrzn-dffr
(progn
(cat:cat-init)
(let ((h (cat:bar-hrzn-dffr (cat:k-z-1)))
(abar))
(dotimes (i 10)
(print (random-abar 10 5)))
(setf abar (random-abar 10 5))
(cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
(cat:? h (cat:? h (apply #'+ (mapcar #'car
(cat:abar-list abar))) abar))
(dotimes (i 10)
(setf abar (random-abar 10 3))
(print abar)
(print (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar))
(print (cat:? h (cat:? h (apply #'+ (mapcar #'car
(cat:abar-list abar)))
abar)))))))
|#
(cat:cat-init)
(let ((h (cat:bar-hrzn-dffr (cat:k-z-1)))
(abar))
(dotimes (i 10)
(print (random-abar 10 5)))
(setf abar (random-abar 10 5))
(cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
(cat:? h (cat:? h (apply #'+ (mapcar #'car
(cat:abar-list abar))) abar))
(dotimes (i 10)
(setf abar (random-abar 10 3))
(print abar)
(print (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar))
(print (cat:? h (cat:? h (apply #'+ (mapcar #'car
(cat:abar-list abar)))
abar)))))))
(test bar
(progn
(cat:cat-init)
(let ((b (cat:bar (cat:k-z-1)))
(abar (random-abar 10 3)))
(cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
(cat:? b (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar))
(dotimes (i 10)
(let ((abar (random-abar 10 3)))
(print abar)
(print (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar))
(print (cat:? b
(cat:? b
(apply #'+ (mapcar #'car
(cat:abar-list abar)))
abar))))))))
(cat:cat-init)
(let ((b (cat:bar (cat:k-z-1)))
(abar (random-abar 10 3)))
(cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
(cat:? b (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar))
(dotimes (i 10)
(let ((abar (random-abar 10 3)))
(print abar)
(print (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar))
(print (cat:? b
(cat:? b
(apply #'+ (mapcar #'car
(cat:abar-list abar)))
abar))))))))
(test ncmbn-bar
@ -139,103 +137,102 @@
(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 1 4 'c 5 'd)
(cat:cmbn 1 6 'e 7 'f))))
(cat:cmbn 1 6 'e 7 'f))))
(test mrph-vrtc-bar-intr
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective
:intr-dffr #'cat:zero-mrph
:strt :cmbn))
(m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr
#'(lambda (degr gnrt)
(cat:cmbn degr 2 gnrt 3 (1+ gnrt)))
:strt :gnrt :orgn '(test)))
(r (cat:mrph-vrtc-bar-intr m)))
(funcall r 4 (cat:abar 2 3 2 4))))
:basis :locally-effective
:intr-dffr #'cat:zero-mrph
:strt :cmbn))
(m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr
#'(lambda (degr gnrt)
(cat:cmbn degr 2 gnrt 3 (1+ gnrt)))
:strt :gnrt :orgn '(test)))
(r (cat:mrph-vrtc-bar-intr m)))
(funcall r 4 (cat:abar 2 3 2 4))))
(test vrtc-bar
(progn
(cat:cat-init)
(let* ((f (cat:aw (cat:soft-delta-infinity)
(cat:soft-delta-infinity)))
(cf (cat:vrtc-bar f)))
(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:cat-init)
(let* ((f (cat:aw (cat:soft-delta-infinity)
(cat:soft-delta-infinity)))
(cf (cat:vrtc-bar f)))
(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)))))))
(test hmtp-vrtc-bar-intr
(progn
(cat:cat-init)
(let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity)))
(h (cat:h ez))
(gf (cat:cmps (cat:g ez) (cat:f ez)))
(r (cat:hmtp-vrtc-bar-intr h gf)))
(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)
3 (cat:crpr 0 14 0 14))))))
(cat:cat-init)
(let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity)))
(h (cat:h ez))
(gf (cat:cmps (cat:g ez) (cat:f ez)))
(r (cat:hmtp-vrtc-bar-intr h gf)))
(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)
3 (cat:crpr 0 14 0 14))))))
#|
(test vrtc-bar1
(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
(progn
(cat:cat-init)
(let* ((h (cat:efhm (cat:k-z-1)))
(b (cat:bar h)))
(cat:homology (cat:rbcc b) 0 11))))
(cat:cat-init)
(let* ((h (cat:efhm (cat:k-z-1)))
(b (cat:bar h)))
(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-suite :kenzo)
#|
(test cs-hat-u-t
(cat:cat-init)
(let* ((c (cat:cs-hat-u-t (cat:k-z-1)))
(abar (random-abar 8 4))
(abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '())
2 '(4 5))
abar-degr abar)))
(cat:? c (+ 5 abar-degr) gnrt)
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) gnrt))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(print (cat:? c (+ 6 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6)) abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 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 11)
(print (cat:? c (+ 4 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
gnrt)))))))))
|#
(let ((c (cat:cs-hat-u-t (cat:k-z-1)))
abar-degr
gnrt)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(print (cat:? c (+ 6 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6)) abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 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 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
(cat:cat-init)
(dotimes (i 5) (print (random-abar 8 4)))
(let* ((c (cat:cs-hat-t-u (cat:k-z-1)))
(abar (random-abar 8 4))
(abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '())
2 '(4 5))
abar-degr abar)))
(cat:? c (+ 5 abar-degr) gnrt)
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) gnrt))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(print (cat:? c (+ 6 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 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 11)
(print (cat:? c (+ 4 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
gnrt)))))))))
|#
(let ((c (cat:cs-hat-t-u (cat:k-z-1)))
abar-degr
gnrt)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(print (cat:? c (+ 6 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 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 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
(cat:cat-init)
(let ((c (cat:cs-left-hmeq-hat (cat:k-z-1)))
abar-degr
gnrt)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(print (cat:? c (+ 6 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 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 11)
(print (cat:? c (+ 4 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
gnrt)))))))))
|#
abar-degr
gnrt)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(print (cat:? c (+ 6 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt)))))))
(dotimes (i 10)
(let ((abar (random-abar 8 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 11)
(print (cat:? c (+ 4 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
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
(cat:cat-init)
(let ((rdct (cat:cs-pre-left-hmeq-left-reduction (cat:k-z-1)))
abar-degr
gnrt
gbar)
(cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1
(cat:tnpr 0 (cat:tnpr 0
cat:+null-gbar+ 0 '())
0 cat:+null-abar+))
cat:*bc* (cat:cmbn 0 1 cat:+null-gbar+))
(check-rdct)
(setf cat:*tc* (cat:cmbn 1 1
(cat:tnpr 1 (cat:tnpr 0
cat:+null-gbar+ 1 '(13))
0 cat:+null-abar+)))
(check-rdct)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 2 '(4 5))
abar-degr abar))
(setf gbar (cat:gbar 2 0 '(1) 0 '()))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn 2 1 gbar))
(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 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 3 '(4 5 6))
abar-degr abar))
(setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '()))
(unless (>= abar-degr 8)
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn 3 1 gbar))
(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 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6))
abar-degr abar))
(setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn 4 1 gbar))
(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))
(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))))))
|#
abar-degr
gnrt
gbar)
(cat:pre-check-rdct rdct)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 2 '(4 5))
abar-degr abar))
(setf gbar (cat:gbar 2 0 '(1) 0 '()))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn 2 1 gbar))
(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 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 3 '(4 5 6))
abar-degr abar))
(setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '()))
(unless (>= abar-degr 8)
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn 3 1 gbar))
(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 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6))
abar-degr abar))
(setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn 4 1 gbar))
(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))
(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
(cat:cat-init)
(let ((rdct (cat:cs-left-hmeq-left-reduction (cat:k-z-1)))
abar-degr gnrt gbar)
(cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0
(cat:tnpr 0 cat:+null-gbar+
0 '()) 0
cat:+null-abar+))
cat:*bc* (cat:cmbn 0 1 cat:+null-gbar+))
(check-rdct)
(setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 1
(cat:tnpr 0 cat:+null-gbar+
1 '(13)) 0
cat:+null-abar+)))
(check-rdct)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 2 '(4 5))
abar-degr abar))
(setf gbar (cat:gbar 2 0 '(1) 0 '()))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn 2 1 gbar))
(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 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 3 '(4 5 6))
abar-degr abar))
(setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '()))
(unless (>= abar-degr 8)
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn 3 1 gbar))
(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 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6))
abar-degr abar))
(setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn 4 1 gbar))
(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))
(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))))))
|#
abar-degr
gnrt
gbar)
(cat:pre-check-rdct rdct)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 2 '(4 5))
abar-degr abar))
(setf gbar (cat:gbar 2 0 '(1) 0 '()))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn 2 1 gbar))
(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 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 3 '(4 5 6))
abar-degr abar))
(setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '()))
(unless (>= abar-degr 8)
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn 3 1 gbar))
(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 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6))
abar-degr abar))
(setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn 4 1 gbar))
(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))
(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
(cat:cs-pre-left-hmeq-right-reduction-intr-f
(cat:cmbn 4 2 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i)
4 (cat:abar 2 'a 2 'b))
3 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i)
4 (cat:abar 2 'a 2 'c))
5 (cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+ 1 'a)
3 (cat:abar 1 'a 2 'b)))))
4 (cat:abar 2 'a 2 'b))
3 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i)
4 (cat:abar 2 'a 2 'c))
5 (cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+ 1 'a)
3 (cat:abar 1 'a 2 'b)))))
(test cs-pre-left-hmeq-right-reduction-g
(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
(cat:cat-init)
(let ((rdct (cat:cs-pre-left-hmeq-right-reduction (cat:k-z-1)))
abar-degr
gnrt)
(cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0
(cat:tnpr 0 cat:+null-gbar+
0 '())
0 cat:+null-abar+))
cat:*bc* (cat:cmbn 0 1 cat:+null-abar+))
(check-rdct)
(setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 1
(cat:tnpr 0 cat:+null-gbar+
1 '(13))
0 cat:+null-abar+)))
(check-rdct)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
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 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 8)
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
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 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 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))))))
|#
abar-degr
gnrt)
(cat:pre-check-rdct rdct)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(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)
0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
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 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 8)
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
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 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 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-right-reduction
(cat:cat-init)
(let ((rdct (cat:cs-left-hmeq-right-reduction (cat:k-z-1)))
abar-degr
gnrt)
(cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1
(cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+
0 '())
0 cat:+null-abar+))
cat:*bc* (cat:cmbn 0 1 cat:+null-abar+))
(check-rdct)
(setf cat:*tc* (cat:cmbn 1 1
(cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+
1 '(13))
0 cat:+null-abar+)))
(check-rdct)
(dotimes (i 10)
(let ((abar (random-abar 4 2)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 3 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
1 '(4))
abar-degr abar))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 3 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn abar-degr 1 abar))
(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 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
2 '(5 6))
abar-degr abar))
(unless (>= abar-degr 8)
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn abar-degr 1 abar))
(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))))))
|#
abar-degr
gnrt)
(cat:pre-check-rdct rdct)
(dotimes (i 10)
(let ((abar (random-abar 4 2)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 3 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
1 '(4))
abar-degr abar))
(unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 3 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn abar-degr 1 abar))
(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 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
2 '(5 6))
abar-degr abar))
(unless (>= abar-degr 8)
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn abar-degr 1 abar))
(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))))))
(test cs-left-hmeq
(cat:cat-init)
(let* ((h (cat:cs-left-hmeq (cat:k-z-1)))
(abar (cat:abar 2 '(2) 3 '(3 4))))
(cat:rf h
(cat:lg h
(cat:lf h
(cat:rg h 5 abar))))))
(abar (cat:abar 2 '(2) 3 '(3 4))))
(cat:rf h
(cat:lg h
(cat:lf h
(cat:rg h 5 abar))))))
(test classifying-space
(cat:cat-init)
(let* ((k (cat:k-z-1))
(bk (cat:classifying-space k))
(obk (cat:loop-space bk)))
(cat:homology k 0 10)
(cat:homology bk 0 10)
(cat:homology obk 0 6)))
(bk (cat:classifying-space k))
(obk (cat:loop-space bk)))
(cat:homology k 0 10)
(cat:homology bk 0 10)
(cat:homology obk 0 6)))

218
test/common.lisp
View File

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

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

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