Use (A×B×C) names for TypedTuples

src/Collections-Homogeneous-Tests/TypedTupleTest.class.st

@@ -0,0 +1,20 @@
+Class {
+	#name : #TypedTupleTest,
+	#superclass : #TestCase,
+	#category : #'Collections-Homogeneous-Tests'
+}
+
+{ #category : #tests }
+TypedTupleTest >> testEmptyProduct [
+	| t |
+	t := TypedTuple empty.
+	self assert: t slots size equals: 0.
+	self assert: (t⨰Integer) slots size equals: 1
+]
+
+{ #category : #tests }
+TypedTupleTest >> testProductComposition [
+	| t |
+	t := Int ⨰ String ⨰ Int.
+	self assert: t slots size equals: 3
+]

src/Collections-Homogeneous-Tests/package.st

@@ -0,0 +1 @@
+Package { #name : #'Collections-Homogeneous-Tests' }

src/Collections-Homogeneous/Array.extension.st

@@ -2,14 +2,5 @@ Extension { #name : #Array }
 
 { #category : #'*Collections-Homogeneous' }
 Array class >> of: elementSpecies [ 
-	| mc c |	
-	mc := HomogeneousArray class copy.
-	c := mc new
-		superclass: HomogeneousArray superclass
-		methodDictionary: HomogeneousArray methodDictionary
-		format: HomogeneousArray format;
-		setName: 'Array of: ', elementSpecies nameForHomoArray;
-		instVarNamed: #elementSpecies put: elementSpecies;
-		yourself.
-	^c
+	^TypedArray of: elementSpecies 
 ]

src/Collections-Homogeneous/Class.extension.st

@@ -4,8 +4,3 @@ Extension { #name : #Class }
 Class >> array [
 	^Array of: self
 ]
-
-{ #category : #'*Collections-Homogeneous' }
-Class >> nameForHomoArray [
-	^self name
-]

src/Collections-Homogeneous/Collection.extension.st

@@ -1,6 +1,6 @@
 Extension { #name : #Collection }
 
 { #category : #'*Collections-Homogeneous' }
-Collection >> isHomogeneous [
+Collection >> isTyped [
 	^false
 ]

src/Collections-Homogeneous/TypedArray.class.st

@@ -0,0 +1,90 @@
+Class {
+	#name : #TypedArray,
+	#superclass : #Array,
+	#type : #variable,
+	#classVars : [
+		'Arrays'
+	],
+	#classInstVars : [
+		'elementSpecies'
+	],
+	#category : #'Collections-Homogeneous'
+}
+
+{ #category : #accessing }
+TypedArray class >> elementSpecies [
+	^elementSpecies
+]
+
+{ #category : #accessing }
+TypedArray class >> elementSpecies: aClass [
+	self assert: aClass isClass.
+	self assert: self ~~ TypedArray. 
+	self assert: elementSpecies isNil.
+
+	elementSpecies := aClass
+]
+
+{ #category : #initialization }
+TypedArray class >> initialize [
+	Arrays := SystemDictionary new.
+]
+
+{ #category : #JSON }
+TypedArray class >> neoJsonMapping: mapper [
+	mapper for: self customDo: [ :mapping |
+		mapping listOfElementSchema: elementSpecies
+	]
+]
+
+{ #category : #'instance creation' }
+TypedArray class >> new: size [
+	self == TypedArray ifTrue:[ self shouldNotImplement ].
+	^super new: size.
+
+	"
+	(TypedArray of: String) new:10.
+	TypedArray new:10.
+	"
+
+
+]
+
+{ #category : #'subclass creation' }
+TypedArray class >> of: aClass [
+	| arrayName arrayClass |
+
+	self assert: aClass isClass.
+
+	arrayName := ('Array of: ', aClass name) asSymbol.
+	[ 
+	arrayClass := self classBuilder
+								name: arrayName;
+								superclass: self;
+								build.
+	] on: InvalidGlobalName do:[:ex|
+		ex resumeUnchecked: nil.
+	].
+
+	arrayClass elementSpecies: aClass.
+	^arrayClass
+
+	"
+	Array of: String
+	"
+
+
+
+
+
+
+
+
+
+
+]
+
+{ #category : #testing }
+TypedArray >> isTyped [
+	^true
+]

src/Collections-Homogeneous/TypedTuple.class.st

@@ -0,0 +1,90 @@
+Class {
+	#name : #TypedTuple,
+	#superclass : #Object,
+	#type : #variable,
+	#category : #'Collections-Homogeneous'
+}
+
+{ #category : #'instance creation' }
+TypedTuple class >> empty [
+	^self ofAll: #()
+]
+
+{ #category : #'instance creation' }
+TypedTuple class >> nameFor: classes [
+	| s |
+	s := WriteStream on: String new.
+	s nextPut: $(.
+	classes
+		do: [ :each | s nextPutAll: each name ]
+		separatedBy: [ s nextPutAll: '×' ].
+	s nextPut: $).
+	^s contents
+]
+
+{ #category : #JSON }
+TypedTuple class >> neoJsonMapping: mapper [
+	mapper for: self customDo: [ :mapping | mapping reader: [ :jsonReader |
+			| stillLeft acc inst |
+
+			stillLeft := self slots asOrderedCollection.
+			acc := OrderedCollection new.
+
+			jsonReader parseListDo: [ acc addLast: (jsonReader nextAs: stillLeft first type).  stillLeft removeFirst ].
+			stillLeft isEmpty ifFalse: [self error].
+			inst := self basicNew.
+			acc withIndexDo: [ :eachValue :j | inst instVarAt: j put: eachValue ].
+			inst
+		]].
+]
+
+{ #category : #'instance creation' }
+TypedTuple class >> new [
+	"Use #ofAll: or #empty."
+	self shouldNotImplement
+]
+
+{ #category : #'instance creation' }
+TypedTuple class >> ofAll: elementNamesAndTypes [
+	| tupleName tupleSlots tupleClass |
+	elementNamesAndTypes do:[:nameAndType | 
+		self assert: (nameAndType isKindOf: Association).
+		self assert: nameAndType key isString.
+		self assert: nameAndType value isClass.
+	].
+	tupleName := self nameFor: (elementNamesAndTypes collect: #value).
+	tupleSlots := elementNamesAndTypes collect:
+								[:nameAndType | TypedTupleSlot named: nameAndType key type: nameAndType value].
+	[
+	tupleClass := self classBuilder
+								name: tupleName;								
+								superclass: self;
+								slots: tupleSlots;
+								build.
+	] on: InvalidGlobalName do:[:ex|
+		ex resumeUnchecked: nil.
+	].
+	^tupleClass
+
+	"
+	TypedTuple ofAll:{ #x -> Integer . #y -> Integer }
+	"
+
+]
+
+{ #category : #accessing }
+TypedTuple class >> slotAssociations [
+	^self slots collect: [ :eachSlot | eachSlot name -> eachSlot type ]
+]
+
+{ #category : #semigroup }
+TypedTuple class >> ⨰ [ anotherClass
+	anotherClass isClass ifFalse: [ self shouldBeImplemented "A×(B×C) case" ].
+	^TypedTuple ofAll:
+		self slotAssociations, { '_', (self instSize + 1) printString -> anotherClass } 
+]
+
+{ #category : #testing }
+TypedTuple >> isTyped [
+	^true
+]

src/Collections-Homogeneous/TypedTupleSlot.class.st

@@ -0,0 +1,59 @@
+Class {
+	#name : #TypedTupleSlot,
+	#superclass : #InstanceVariableSlot,
+	#instVars : [
+		'type'
+	],
+	#category : #'Collections-Homogeneous'
+}
+
+{ #category : #'instance creation' }
+TypedTupleSlot class >> named: aString type: aClass [
+	^self new
+		name: aString;
+		type: aClass;
+		yourself.
+]
+
+{ #category : #comparing }
+TypedTupleSlot >> = other [
+	^ super = other and: [type = other type]
+]
+
+{ #category : #comparing }
+TypedTupleSlot >> hash [
+	^(super hash + type hash) hashMultiply 
+]
+
+{ #category : #initalize }
+TypedTupleSlot >> initialize: anObject [
+	self write: type new to: anObject
+]
+
+{ #category : #printing }
+TypedTupleSlot >> printOn: aStream [
+	"Every subclass that adds state must redefine either this method or #definitionString"
+	aStream 
+		nextPutAll: self class name;
+		nextPutAll: ' named: '.
+	self name storeOn: aStream.
+	aStream nextPutAll: ' type: '.
+	self type storeOn: aStream
+]
+
+{ #category : #accessing }
+TypedTupleSlot >> type [
+	^ type
+]
+
+{ #category : #accessing }
+TypedTupleSlot >> type: aClass [ 
+	self assert: aClass isClass.
+	type := aClass
+]
+
+{ #category : #'meta-object-protocol' }
+TypedTupleSlot >> wantsInitialization [
+	"we need to call the initialize to set the default value for the base slot"
+	^"true"false"<-- We need more magic in initialize: to support for example Integer"
+]

src/Deduction-Pharo/Rule.extension.st

@@ -0,0 +1,36 @@
+Extension { #name : #Rule }
+
+{ #category : #'*Deduction-Pharo' }
+Rule >> asTextMorph [
+	| fontWidth premissMorphs premissText premissWidth conclusionMorph conclusionText conclusionWidth maxWidth hl hlWidth |
+	fontWidth := 'xxxxxxxxxx' asTextMorph width / 10.
+	premissMorphs := premisses collect: [ :eachPremiss | eachPremiss asTextMorph backgroundColor: Color white; yourself ].
+	premissText := Text streamContents: [ :s | premissMorphs
+			do: [ :each | each imageForm printOn: s ]
+			separatedBy: [ s nextPutAll: '   ' ] ].
+
+	conclusionMorph := conclusion asTextMorph backgroundColor: Color white; yourself.
+	conclusionText := Text streamContents: [ :s | conclusionMorph imageForm printOn: s ].
+
+	premissWidth := premissText asTextMorph width.
+	conclusionWidth := conclusionText asTextMorph width.
+	maxWidth := premissWidth max: conclusionWidth.
+
+	hl := Text
+			new: (maxWidth / fontWidth + 2.5) ceiling
+			withAll: (Character codePoint: 16r23AF). "Horizontal Line Extension"
+	hlWidth := hl asTextMorph width.
+
+	^((Text "pad premiss to center"
+				new: (hlWidth - premissWidth / 2 / fontWidth) rounded
+				withAll: $ ),
+		premissText,
+		String cr asText,
+		hl,
+		('[', name, ']') asText,
+		String cr asText,
+		(Text "pad conclusion to center"
+				new: (hlWidth - conclusionWidth / 2 / fontWidth) rounded
+				withAll: $ ),
+		conclusionText) asTextMorph backgroundColor: Color white; yourself
+]

src/Deduction-Pharo/package.st

@@ -0,0 +1 @@
+Package { #name : #'Deduction-Pharo' }

src/Deduction-Tests/DeductionRuleTest.class.st

@@ -0,0 +1,49 @@
+Class {
+	#name : #DeductionRuleTest,
+	#superclass : #TestCase,
+	#category : #'Deduction-Tests'
+}
+
+{ #category : #examples }
+DeductionRuleTest >> example1 [
+	^Rule
+		premisses: #(A B)
+		conclusion: #C
+		name: 'Ax'
+]
+
+{ #category : #examples }
+DeductionRuleTest >> example2 [
+	| d1 d |
+	d1 := Rule
+		premisses: #(1)
+		conclusion: 1234567890
+		name: 'INTRO'.
+	d := Rule
+		premisses: {d1 . 2}
+		conclusion: 3
+		name: 'ELIM'.
+	^d
+]
+
+{ #category : #examples }
+DeductionRuleTest >> test1 [
+	| r |
+	r := self example1.
+
+]
+
+{ #category : #examples }
+DeductionRuleTest >> testGT [
+	| r |
+	r := self example2.
+	r asTextMorph halt
+]
+
+{ #category : #examples }
+DeductionRuleTest >> testGTXX [
+	| r f |
+	f := '/home/boris/boris2.jpg' asFileReference.
+	r := self example2.
+	r asTextMorph halt
+]

src/Deduction-Tests/package.st

@@ -0,0 +1 @@
+Package { #name : #'Deduction-Tests' }