Set consolidation: Difference between revisions
Added various BASIC dialects (BASIC256, Chipmunk Basic, FreeBASIC, Gambas, GW-BASIC, MSX Basic, PureBasic, QBasic, Run BASIC, XBasic and Yabasic)
m (→{{header|Wren}}: Minor tidy) |
(Added various BASIC dialects (BASIC256, Chipmunk Basic, FreeBASIC, Gambas, GW-BASIC, MSX Basic, PureBasic, QBasic, Run BASIC, XBasic and Yabasic)) |
||
Line 318:
[["A","B","C","D"]]
[["A","B","C","D"] , ["F","G","H","I","K"]]</pre>
=={{header|BASIC}}==
==={{header|BASIC256}}===
{{trans|FreeBASIC}}
<syntaxhighlight lang="vbnet">dim test$(4)
test$[0] = "AB"
test$[1] = "AB,CD"
test$[2] = "AB,CD,DB"
test$[3] = "HIK,AB,CD,DB,FGH"
for t = 0 to 3 #test$[?]
print Consolidate(test$[t])
next t
end
function Consolidate(s$)
dim sets$(100)
# Split the string into substrings
pio = 1
n = 0
for i = 1 to length(s$)
if mid(s$, i, 1) = "," then
fin = i - 1
sets$[n] = mid(s$, pio, fin - pio + 1)
pio = i + 1
n += 1
end if
next i
sets$[n] = mid(s$, pio, length(s$) - pio + 1)
# Main logic
for i = 0 to n
p = i
ts$ = ""
for j = i to 0 step -1
if ts$ = "" then p = j
ts$ = ""
for k = 1 to length(sets$[p])
if j > 0 then
if instr(sets$[j-1], mid(sets$[p], k, 1)) = 0 then
ts$ += mid(sets$[p], k, 1)
end if
end if
next k
if length(ts$) < length(sets$[p]) then
if j > 0 then
sets$[j-1] = sets$[j-1] + ts$
sets$[p] = "-"
ts$ = ""
end if
else
p = i
end if
next j
next i
# Join the substrings into a string
temp$ = sets$[0]
for i = 1 to n
temp$ += "," + sets$[i]
next i
return s$ + " = " + temp$
end function</syntaxhighlight>
{{out}}
<pre>Same as FreeBASIC entry.</pre>
==={{header|Chipmunk Basic}}===
{{works with|Chipmunk Basic|3.6.4}}
Same code as [[#GW-BASIC|GW-BASIC]]
==={{header|FreeBASIC}}===
{{trans|Ring}}
<syntaxhighlight lang="vbnet">Function Consolidate(s As String) As String
Dim As Integer i, j, k, p, n, pio, fin
Dim As String ts, sets(0 To 100), temp
' Split the string into substrings
pio = 1
n = 0
For i = 1 To Len(s)
If Mid(s, i, 1) = "," Then
fin = i - 1
sets(n) = Mid(s, pio, fin - pio + 1)
pio = i + 1
n += 1
End If
Next i
sets(n) = Mid(s, pio, Len(s) - pio + 1)
' Main logic
For i = 0 To n
p = i
ts = ""
For j = i To 0 Step -1
If ts = "" Then p = j
ts = ""
For k = 1 To Len(sets(p))
If j > 0 Then
If Instr(sets(j-1), Mid(sets(p), k, 1)) = 0 Then ts += Mid(sets(p), k, 1)
End If
Next k
If Len(ts) < Len(sets(p)) Then
If j > 0 Then
sets(j-1) += ts
sets(p) = "-"
ts = ""
End If
Else
p = i
End If
Next j
Next i
' Join the substrings into a string
temp = sets(0)
For i = 1 To n
temp += "," + sets(i)
Next i
Return s + " = " + temp
End Function
Dim As String test(3) = {"AB", "AB,CD", "AB,CD,DB", "HIK,AB,CD,DB,FGH"}
For t As Integer = Lbound(test) To Ubound(test)
Print Consolidate(test(t))
Next t
Sleep</syntaxhighlight>
{{out}}
<pre>Same as Ring entry.</pre>
==={{header|Gambas}}===
{{trans|Ring}}
<syntaxhighlight lang="vbnet">Public test As String[] = ["AB", "AB,CD", "AB,CD,DB", "HIK,AB,CD,DB,FGH"]
Public Sub Main()
For t As Integer = 0 To test.Max
Print Consolidate(test[t])
Next
End
Public Function Consolidate(s As String) As String
Dim sets As New String[100]
Dim n As Integer, i As Integer, j As Integer, k As Integer, p As Integer
Dim ts As String, tmp As String
n = 0
For i = 1 To Len(s)
If Mid(s, i, 1) = "," Then
n += 1
Else
sets[n] = sets[n] & Mid(s, i, 1)
Endif
Next
For i = 0 To n
p = i
ts = ""
For j = i To 0 Step -1
If ts = "" Then p = j
ts = ""
For k = 1 To Len(sets[p])
If j > 0 Then
If InStr(sets[j - 1], Mid(sets[p], k, 1)) = 0 Then
ts &= Mid(sets[p], k, 1)
Endif
Endif
Next
If Len(ts) < Len(sets[p]) Then
If j > 0 Then
sets[j - 1] &= ts
sets[p] = "-"
ts = ""
Endif
Else
p = i
Endif
Next
Next
tmp = sets[0]
For i = 1 To n
tmp &= "," & sets[i]
Next
Return s & " = " & tmp
End</syntaxhighlight>
{{out}}
<pre>Same as Ring entry.</pre>
==={{header|GW-BASIC}}===
{{works with|PC-BASIC|any}}
{{works with|BASICA}}
{{works with|Chipmunk Basic}}
{{works with|QBasic}}
{{works with|MSX BASIC}}
<syntaxhighlight lang="qbasic">100 CLS
110 S$ = "AB" : GOSUB 160
120 S$ = "AB,CD" : GOSUB 160
130 S$ = "AB,CD,DB" : GOSUB 160
140 S$ = "HIK,AB,CD,DB,FGH" : GOSUB 160
150 END
160 DIM R$(20)
170 N = 0
180 FOR I = 1 TO LEN(S$)
190 IF MID$(S$,I,1) = "," THEN N = N+1 : GOTO 210
200 R$(N) = R$(N)+MID$(S$,I,1)
210 NEXT I
220 FOR I = 0 TO N
230 P = I
240 TS$ = ""
250 FOR J = I TO 0 STEP -1
260 IF TS$ = "" THEN P = J
270 TS$ = ""
280 FOR K = 1 TO LEN(R$(P))
290 IF J > 0 THEN IF INSTR(R$(J-1),MID$(R$(P),K,1)) = 0 THEN TS$ = TS$+MID$(R$(P),K,1)
300 NEXT K
310 IF LEN(TS$) < LEN(R$(P)) THEN IF J > 0 THEN R$(J-1) = R$(J-1)+TS$ : R$(P) = "-" : TS$ = ""
320 NEXT J
330 NEXT I
340 T$ = R$(0)
350 FOR I = 1 TO N
360 T$ = T$+","+R$(I)
370 NEXT I
380 PRINT S$;" = ";T$
390 ERASE R$
400 RETURN</syntaxhighlight>
{{out}}
<pre>AB = AB
AB,CD = AB,CD
AB,CD,DB = ABCD,-,-
HIK,AB,CD,DB,FGH = HIKFG,ABCD,-,-,-</pre>
==={{header|MSX Basic}}===
{{works with|MSX BASIC|any}}
Same code as [[#GW-BASIC|GW-BASIC]]
==={{header|PureBasic}}===
<syntaxhighlight lang="purebasic">Procedure.s Consolidate(s.s)
Dim sets.s(100)
Define.i n, i, j, k, p
Define.s ts.s, temp.s
n = 0
For i = 1 To Len(s)
If Mid(s, i, 1) = ",":
n + 1
Else
sets(n) = sets(n) + Mid(s, i, 1)
EndIf
Next i
For i = 0 To n
p = i
ts = ""
For j = i To 0 Step -1
If ts = "":
p = j
EndIf
ts = ""
For k = 1 To Len(sets(p))
If j > 0:
If FindString(sets(j-1), Mid(sets(p), k, 1)) = 0:
ts = ts + Mid(sets(p), k, 1)
EndIf
EndIf
Next k
If Len(ts) < Len(sets(p)):
If j > 0:
sets(j-1) = sets(j-1) + ts
sets(p) = "-"
ts = ""
EndIf
Else
p = i
EndIf
Next j
Next i
temp = sets(0)
For i = 1 To n
temp = temp + "," + sets(i)
Next i
ProcedureReturn s + " = " + temp
EndProcedure
OpenConsole()
Dim test.s(3) ;= {"AB","AB,CD","AB,CD,DB","HIK,AB,CD,DB,FGH"}
test(0) = "AB"
test(1) = "AB,CD"
test(2) = "AB,CD,DB"
test(3) = "HIK,AB,CD,DB,FGH"
For t.i = 0 To 3
PrintN(Consolidate(test(t)))
Next t
PrintN(#CRLF$ + "Press ENTER to exit"): Input()
CloseConsole()</syntaxhighlight>
{{out}}
<pre>Same as Ring entry.</pre>
==={{header|QBasic}}===
{{trans|Ring}}
{{works with|QBasic|1.1}}
{{works with|QuickBasic|4.5}}
<syntaxhighlight lang="qbasic">SUB consolidate (s$)
DIM sets$(100)
n = 0
FOR i = 1 TO LEN(s$)
IF MID$(s$, i, 1) = "," THEN
n = n + 1
ELSE
sets$(n) = sets$(n) + MID$(s$, i, 1)
END IF
NEXT i
FOR i = 0 TO n
p = i
ts$ = ""
FOR j = i TO 0 STEP -1
IF ts$ = "" THEN
p = j
END IF
ts$ = ""
FOR k = 1 TO LEN(sets$(p))
IF j > 0 THEN
IF INSTR(sets$(j - 1), MID$(sets$(p), k, 1)) = 0 THEN
ts$ = ts$ + MID$(sets$(p), k, 1)
END IF
END IF
NEXT k
IF LEN(ts$) < LEN(sets$(p)) THEN
IF j > 0 THEN
sets$(j - 1) = sets$(j - 1) + ts$
sets$(p) = "-"
ts$ = ""
END IF
ELSE
p = i
END IF
NEXT j
NEXT i
temp$ = sets$(0)
FOR i = 1 TO n
temp$ = temp$ + "," + sets$(i)
NEXT i
PRINT s$; " = "; temp$
END SUB
DIM test$(3)
test$(0) = "AB"
test$(1) = "AB,CD"
test$(2) = "AB,CD,DB"
test$(3) = "HIK,AB,CD,DB,FGH"
FOR t = 0 TO 3
CALL consolidate(test$(t))
NEXT t</syntaxhighlight>
{{out}}
<pre>Same as Ring entry.</pre>
==={{header|Run BASIC}}===
{{trans|QBasic}}
<syntaxhighlight lang="vbnet">function consolidate$(s$)
dim sets$(100)
n = 0
for i = 1 to len(s$)
if mid$(s$, i, 1) = "," then
n = n + 1
else
sets$(n) = sets$(n) + mid$(s$, i, 1)
end if
next i
for i = 0 to n
p = i
ts$ = ""
for j = i to 0 step -1
if ts$ = "" then p = j
ts$ = ""
for k = 1 to len(sets$(p))
if j > 0 then
if instr(sets$(j-1), mid$(sets$(p), k, 1)) = 0 then
ts$ = ts$ + mid$(sets$(p), k, 1)
end if
end if
next k
if len(ts$) < len(sets$(p)) then
if j > 0 then
sets$(j-1) = sets$(j-1) + ts$
sets$(p) = "-"
ts$ = ""
end if
else
p = i
end if
next j
next i
temp$ = sets$(0)
for i = 1 to n
temp$ = temp$ + "," + sets$(i)
next i
consolidate$ = s$ + " = " + temp$
end function
dim test$(3)
test$(0) = "AB"
test$(1) = "AB,CD"
test$(2) = "AB,CD,DB"
test$(3) = "HIK,AB,CD,DB,FGH"
for t = 0 to 3
print consolidate$(test$(t))
next t</syntaxhighlight>
==={{header|XBasic}}===
{{trans|BASIC256}}
{{works with|Windows XBasic}}
<syntaxhighlight lang="qbasic">PROGRAM "Set consolidation"
VERSION "0.0001"
DECLARE FUNCTION Entry ()
DECLARE FUNCTION Consolidate$ (s$)
FUNCTION Entry ()
DIM test$[4]
test$[0] = "AB"
test$[1] = "AB,CD"
test$[2] = "AB,CD,DB"
test$[3] = "HIK,AB,CD,DB,FGH"
FOR t = 0 TO 3
PRINT Consolidate$(test$[t])
NEXT t
END FUNCTION
FUNCTION Consolidate$ (s$)
DIM sets$[100]
' Split the STRING into substrings
pio = 1
n = 0
FOR i = 1 TO LEN(s$)
IF MID$(s$, i, 1) = "," THEN
fin = i - 1
sets$[n] = MID$(s$, pio, fin - pio + 1)
pio = i + 1
INC n
END IF
NEXT i
sets$[n] = MID$(s$, pio, LEN(s$) - pio + 1)
' Main logic
FOR i = 0 TO n
p = i
ts$ = ""
FOR j = i TO 0 STEP -1
IF ts$ = "" THEN p = j
ts$ = ""
FOR k = 1 TO LEN(sets$[p])
IF j > 0 THEN
IF INSTR(sets$[j-1], MID$(sets$[p], k, 1)) = 0 THEN
ts$ = ts$ + MID$(sets$[p], k, 1)
END IF
END IF
NEXT k
IF LEN(ts$) < LEN(sets$[p]) THEN
IF j > 0 THEN
sets$[j-1] = sets$[j-1] + ts$
sets$[p] = "-"
ts$ = ""
END IF
ELSE
p = i
END IF
NEXT j
NEXT i
' Join the substrings into a STRING
temp$ = sets$[0]
FOR i = 1 TO n
temp$ = temp$ + "," + sets$[i]
NEXT i
RETURN s$ + " = " + temp$
END FUNCTION
END PROGRAM</syntaxhighlight>
{{out}}
<pre>Same as BASIC256 entry.</pre>
==={{header|Yabasic}}===
{{trans|FreeBASIC}}
<syntaxhighlight lang="vbnet">dim test$(3)
test$(0) = "AB"
test$(1) = "AB,CD"
test$(2) = "AB,CD,DB"
test$(3) = "HIK,AB,CD,DB,FGH"
for t = 0 to arraysize(test$(), 1)
print Consolidate$(test$(t))
next t
end
sub Consolidate$(s$)
dim sets$(100)
// Split the string into substrings
pio = 1
n = 0
for i = 1 to len(s$)
if mid$(s$, i, 1) = "," then
fin = i - 1
sets$(n) = mid$(s$, pio, fin - pio + 1)
pio = i + 1
n = n + 1
fi
next i
sets$(n) = mid$(s$, pio, len(s$) - pio + 1)
// Main logic
for i = 0 to n
p = i
ts$ = ""
for j = i to 0 step -1
if ts$ = "" p = j
ts$ = ""
for k = 1 to len(sets$(p))
if j > 0 then
if instr(sets$(j-1), mid$(sets$(p), k, 1)) = 0 then
ts$ = ts$ + mid$(sets$(p), k, 1)
fi
fi
next k
if len(ts$) < len(sets$(p)) then
if j > 0 then
sets$(j-1) = sets$(j-1) + ts$
sets$(p) = "-"
ts$ = ""
fi
else
p = i
fi
next j
next i
// Join the substrings into a string
temp$ = sets$(0)
for i = 1 to n
temp$ = temp$ + "," + sets$(i)
next i
return s$ + " = " + temp$
end sub</syntaxhighlight>
{{out}}
<pre>Same as FreeBASIC entry.</pre>
=={{header|Bracmat}}==
| |||