https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Graphs and Networks with no replies sorted by most viewed. https://community.wolfram.com/groups/-/m/t/497445 Today I watched this TED talk "[Why city flags may be the worst-designed thing you've never noticed][1]" and it made me really curious about how the five basic principles of flag design apply to countries. Certainly, most country flags are so simple that a child can draw them from memory. But this principle increases the odds of having flag duplicates, and to show this I've written the following WL code: countries = CountryData["Countries", "Name"]; flags = Rasterize /@ CountryData["Countries", "Flag"]; similarities = # -> First[Nearest[DeleteCases[flags, #], #]] & /@ flags; g = Graph[Labeled[#[[2]],Placed[Tooltip[#[[2]],#[[1]]],{.7,.6}]]&/@Transpose[{countries,flags}],similarities,ImageSize->3500] ![Flags of all countries group by similarity][2] ImageCollage[Length[#] -> ImageCollage[#] & /@ WeaklyConnectedComponents[g]] ![Flags Collage by Similarity][3] GraphicsGrid[Partition[Flatten[WeaklyConnectedComponents[g]], 6], Background -> Gray] ![List of similar flags][4] Feel free to explore the similarity graph of flags in the CDF attached below. ![Flag Similarity Graph][6] Are these similarities mere accidents or deliberate flag copies? Mapping the countries with similar flags might answer this question. To get started, here is how to [Map the Countries of Africa with Their Flags][5]. [1]: https://www.ted.com/talks/roman_mars_why_city_flags_may_be_the_worst_designed_thing_you_ve_never_noticed [2]: /c/portal/getImageAttachment?filename=SimilarityCountryFlagsGraph.png&userId=56204 [3]: /c/portal/getImageAttachment?filename=SimilarityCountryFlagsCollage.png&userId=56204 [4]: /c/portal/getImageAttachment?filename=SimilarityFlagsGrid.png&userId=56204 [5]: http://www.wolfram.com/mathematica/new-in-10/entity-based-geocomputation/map-the-countries-of-africa-with-their-flags.html [6]: /c/portal/getImageAttachment?filename=FlagGraph.gif&userId=56204 Bernat Espigulé 2015-05-15T20:25:24Z https://community.wolfram.com/groups/-/m/t/1136952 # **Growth and spreading of topics on inSpireHEP**# Brief and tentative description of the project carried out at the 2017 Wolfram Summer School. The Mathematica notebook can be found [here][1]. ## Goal of the project ## The project has a twofold goal. Given a keyword representing a scientific topic (e.g., entanglement, gravitational waves, etc...), we compute the number of occurrences of the keyword that appears in the abstracts of papers in a given time interval and we study how papers about a specific topic are related to each other by analyzing the corresponding citations. In particular, we construct the citation graph associated to the topic and we display its time evolution. ## Summary of the work## As a preliminary step, we download an updated snapshot of record metadata in JSON format containing information about one million of papers posted on inSpireHEP. After adjusting the database to our purposes, we collect the abstracts year by year. The first goal is reached by using the built-in function StringCount, which counts how many times the keyword appears in the abstracts within a given time interval. Then we chart the occurrences by using DateListPlot and few examples of keyword search are shown. The second goal is achieved by selecting those papers concerning the chosen topic and by associating each of these papers to their list of citations. We construct the corresponding citation graph and highlight the communities by centrality-based clustering criterion. We emphasize those papers whose position is relevant for the topology of the graph. Finally, we introduce a further time selection of papers (in addition to the topic selection) in order to display the time evolution of the graph. ##**Code explanation**## First of all, we download the JSON file containing the record metadata (ID, title, abstract, authors, citations, references, publication date, etc...) from [inSpireHEP website][2] and save it as inSpire.json. Then we import the file using the following line: data = Part[ Reap[ Module[ {line, file = FileNameJoin[{NotebookDirectory[], "inSpire.json"}]}, Quiet@Close[file]; OpenRead[file]; While[line =!= EndOfFile, line = ReadString[file, "\n"]; Replace[line, _String :> Sow@Developer`ReadRawJSONString[line]]]; ] ], 2, 1 ]; and save it DumpSave["inSpire.mx", data] The next step is to import the data << inSpire.mx and clean it for our objectives. We will call the clean data `pubdata`. For future convenience, we collect the abstracts year by year. We create an association between the creation date and the abstract of the paper and we organizeit in chronological order: abstractsWithDates = KeySort[#CreationDate -> #abstract & /@ Normal@pubdata // Association] ; We define a function to compare the year of two papers equalDates[date2_][date1_] := MatchQ[DateObject[DateValue[date1, "Year"]], DateObject[DateValue[date2, "Year"]]] and we select all those papers published in that given year: abstractsAtYear[date_] := KeySelect[abstractsWithDates, equalDates[date]] abstractYearData[date_] := Values@abstractsAtYear[date] // StringRiffle and finally we collect all the abstracts year by year from 1930 to 2017: abstractText = AssociationMap[abstractYearData, DateRange[DateObject[{1930}], DateObject[{2017}], Quantity[1, "Years"]]]; To avoid this evaluation every time, we save the abstracts collection in abstractText: DumpSave[FileNameJoin@{NotebookDirectory[], "abstractText.mx"}, abstractText] ---------- ##Occurrences of keywords in abstract in a given time interval## We are in a position to build a easy search engine for keywords in the abstracts. The user has two degrees of freedom in his search: the keyword and the time interval. The research engine is a useful analytical tool to show the trend of a topic in the time range. In the following, we present some representative examples. We import all the abstracts << abstractText.mx and define a function that counts how many times a given keyword appears in abstracts published in that year: stringCountsAt[date_, words_] := StringCount[abstractText[date], words]; stringCountsAt[words_][date_] := stringCountsAt[date, words] how many times a given keyword is counted up to that year: stringCountUpTo[year_, words_, start_: Automatic] := Map[ stringCountsAt[words], Range[Replace[start, Automatic :> Min@Keys[abstractText]], Replace[year, _Integer :> DateObject[{year}]], Quantity[1, "Years"]] ] and how many occurrences in a time interval: occurrences[word_String, dateStart_, dateEnd_] := {#, stringCountUpTo[#, word] // Total} & /@ Range[Replace[dateStart, _Integer :> DateObject[{dateStart}]], Replace[dateEnd, _Integer :> DateObject[{dateEnd}]], Quantity[1, "Years"]] // TimeSeries We plot the occurrences of the keyword "Higgs" between 1985 and 2015 DateListPlot[ {occurrences["Higgs", 1985, 2015]}, Joined -> True, PlotLegends -> Placed[{"Higgs"}, {0.2, 0.8}], PlotTheme -> "Detailed", PlotRange -> Full ] ![Occurrences of the keyword "Higgs" from 1985 to 2015][3] ##Citations graph and its time evolution## In this section, we explain how to construct the citations graph for a given topic. The citations graph is an useful tool to visualize the relations between papers concerning the same topic and to highlight hidden properties among them. To meet this aim, we construct the citations graph of those papers about the "BMS group" We select the papers with more than 20 citations: citationsData = Select[ pubdata, Length[#["citations"]] >= 20 & ]; and we define an association between ID and citations list, authors, abstracts and titles: idWithCitations = #recid -> #citations & /@ Normal@citationsData // Association ; idAuthor = #recid -> #authors & /@ Normal@citationsData // Association ; idAbstract = #recid -> #abstract & /@ Normal@citationsData // Association ; idTitle = #recid -> #title & /@ Normal@citationsData // Association ; idCreationDate = #recid -> #CreationDate & /@ Normal@citationsData // Association ; We need to define other functions to compare dates and years: compareDates[date1_, date2_] := If[DateOverlapsQ[date1, date2], DateObject[{DateValue[date1, "Year"]}], date1 < date2]; compareDates[date1_][date2_] := compareDates[date2, date1]; compareYears[date1_, date2_] := date1 <= date2; compareYears[date1_Integer][date2_] := compareYears[date2, date1]; compareYears[date1_DateObject] := compareYears[DateValue[date1, "Year"]]; We select those papers containing the keyword in the abstract and define the association between the ID and the citations list: idAbstractswithWord[words_String] := Keys@Select[idAbstract, StringContainsQ[words]] idWithCitationsandTopic[words_String] := Thread[# -> Lookup[idWithCitations, #]] &@idAbstractswithWord[words] and plot the graph associated to that keyword (representing a concept/topic) graphTopic = Graph[ Thread /@ idWithCitationsandTopic["BMS group"] // Flatten, DirectedEdges -> False, VertexStyle -> Red, VertexSize -> Automatic, ImageSize -> Automatic ]; We define the highly central vertices: highlyCentral[graph_] := Pick[ VertexList@graph, GreaterThan[10] /@ DegreeCentrality@graph ] and display all the graph communities: HighlightGraph[ HighlightGraph[ graphTopic, Map[Subgraph[graphTopic, #] &, FindGraphCommunities[graphTopic, Method -> "Centrality"]]], Style[highlyCentral[graphTopic], Black], ImageSize -> Large ] ![Citation graph for the keyword/topic "BMS group"][4] Within the whole set of papers about the "BMS group", we might select the most cited papers. The number of citations is usually a reliable bibliometric quantity to evaluate the scientific quality of a paper. In the graph above, we highlighted the graph communities in different colors and the papers with the highest degree of centrality in black. The latter set of papers is a subset of the most cited papers and they play an important role in the topological structure of the graph. In other words, among the most cited papers, we introduce the centrality-based clustering criterion to select the most "important" papers. As an example, the black vertex inside the yellow community is the so-called vertex cut. A vertex cut is that vertex whose removal renders the graph disconnected. In this respect, that paper connects different communities (i.e., different sub-topics) and it represents a seminal paper in the field because it has a non trivial topological position in the graph. In the case at hand, it is the paper by Ashtekar entitled "A unified treatment of null and spatial infinity in general relativity. I - Universal structure, asymptotic symmetries, and conserved quantities at spatial infinity". It is also interesting to visualize the time evolution of the graph during a given time interval. To achieve this result, we need snapshots of the citations graphs year by year. In other words, we need to further select papers by date, in addition to the first selection by topic, and construct the corresponding graph. We therefore select those papers about a given topic published up to a given date: idCreationYear = DateValue[#, "Year"] & /@ idCreationDate; idAbstractswithDateTopic[date_, words_String] := Intersection[Keys@Select[idCreationYear, compareYears[date]], Keys@Select[idAbstract, StringContainsQ[words]]] idCitations[date_, words_String] := Thread[# -> Lookup[idWithCitations, #]] &@ idAbstractswithDateTopic[date, words] and compute the time evolution from 1978 to 2008 timeEvo = idCitations[#, "BMS group"] & /@ DateRange[DateObject[{1978}], DateObject[{2008}], Quantity[1, "Years"]]; timeEvoPruned = With[{edges = Flatten[Thread /@ #]}, Select[edges, Not@*MemberQ[Alternatives @@ #]] &@ Pick[VertexList@edges, LessThan[0] /@ VertexDegree[edges]] ] & /@ timeEvo; g = Table[ Graph[timeEvoPruned[[i]], DirectedEdges -> False, VertexStyle -> Red, VertexSize -> Small, ImageSize -> Automatic], {i, 1, Length[timeEvoPruned]}]; CommunityConnectedGraph = Table[ HighlightGraph[g[[i]], Map[Subgraph[g[[i]], #] &, FindGraphCommunities[g[[i]], Method -> "Centrality"]]], {i, 1, Length[g]}]; ListAnimate[CommunityConnectedGraph] For the "BMS group" the citations graph has the following growth: ![enter image description here][5] ![enter image description here][6] ![enter image description here][7] ![enter image description here][8] ![enter image description here][9] ##**Conclusion and future work**## In this project, we defined a search engine that charts occurrences of any keyword in the abstracts of papers posted on inSpireHEP/arXiv.org and constructed the corresponding citation graph and highlighted the communities by centrality-based clustering criterion. We emphasized those papers about one specific chosen topic that play an important role in the structure of the citations graph, because of their high degree of centrality and not only because they are the most cited papers in the field. Finally, we displayed the time evolution of the graph. Future directions of investigation require more complete database and a detailed analysis of the topological properties of the graph. [1]: https://github.com/ROliveri89/WSS17_material [2]: https://inspirehep.net/info/hep/api [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Higgs.jpg&userId=1081377 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=graph1.jpg&userId=1081377 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=evo1.jpg&userId=1081377 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=evo2.jpg&userId=1081377 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=evo3.jpg&userId=1081377 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=evo4.jpg&userId=1081377 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=evo5.jpg&userId=1081377 Roberto Oliveri 2017-07-05T21:17:01Z https://community.wolfram.com/groups/-/m/t/921122 The [La Jolla Covering Repository](https://www.ccrwest.org/cover/low_tab.html) has a collection of *covers*. For example, my post [Smallest Project Space](http://community.wolfram.com/groups/-/m/t/816281) has the C(15,3,2) cover. From numbers to 15, lines of 3 cover all possible subsets of 2, in 35 lines. No subset is reused anywhere within the lines, so this is called a perfect covering. Another well known example is the [Golay code](http://demonstrations.wolfram.com/GolayCode/) [C(24,8,5)](https://www.ccrwest.org/cover/t_pages/t5/k8/C_24_8_5.html). From numbers to 24, lines of 8 cover all possible subsets of 5, in 759 lines. ![smallest projective][1] I wondered what the status was for perfect coverings, so I took a look. [C(7,3,2)](https://www.ccrwest.org/cover/t_pages/t2/k3/C_7_3_2.html) (Fano plane), [C(9,3,2)](https://www.ccrwest.org/cover/t_pages/t2/k3/C_9_3_2.html), [C(13,3,2)](https://www.ccrwest.org/cover/t_pages/t2/k3/C_13_3_2.html), [C(15,3,2)](https://www.ccrwest.org/cover/t_pages/t2/k3/C_15_3_2.html) (smallest projective space), [C(19,3,2)](https://www.ccrwest.org/cover/t_pages/t2/k3/C_19_3_2.html), [C(21,3,2)](https://www.ccrwest.org/cover/t_pages/t2/k3/C_21_3_2.html), [C(25,3,2)](https://www.ccrwest.org/cover/t_pages/t2/k3/C_25_3_2.html), and more with mod-6 equal to 1 or 3: 27, 31, 33, 37, 39, 43, 45, 49, 51, 55, 57. [C(13,4,2)](https://www.ccrwest.org/cover/t_pages/t2/k4/C_13_4_2.html), [C(16,4,2)](https://www.ccrwest.org/cover/t_pages/t2/k4/C_16_4_2.html), [C(25,4,2)](https://www.ccrwest.org/cover/t_pages/t2/k4/C_25_4_2.html), [C(28,4,2)](https://www.ccrwest.org/cover/t_pages/t2/k4/C_28_4_2.html), [C(37,4,2)](https://www.ccrwest.org/cover/t_pages/t2/k4/C_37_4_2.html), [C(40,4,2)](https://www.ccrwest.org/cover/t_pages/t2/k4/C_40_4_2.html), and more with mod 12 equal to 1 or 4: 49, 52, 61, 64, 73, 76, 85, 88, 97, 100. [C(21,5,2)](https://www.ccrwest.org/cover/t_pages/t2/k5/C_21_5_2.html), [C(25,5,2)](https://www.ccrwest.org/cover/t_pages/t2/k5/C_25_5_2.html), [C(41,5,2)](https://www.ccrwest.org/cover/t_pages/t2/k5/C_41_5_2.html), [C(45,5,2)](https://www.ccrwest.org/cover/t_pages/t2/k5/C_45_5_2.html), and more with mod 20 equal to 1 or 5: 61, 65, 81, 85. Then things start getting interesting. [C(31,6,2)](https://www.ccrwest.org/cover/t_pages/t2/k6/C_31_6_2.html), [C(66,6,2)](https://www.ccrwest.org/cover/t_pages/t2/k6/C_66_6_2.html), [C(76,6,2)](https://www.ccrwest.org/cover/t_pages/t2/k6/C_76_6_2.html), [C(91,6,2)](https://www.ccrwest.org/cover/t_pages/t2/k6/C_91_6_2.html), [C(96,6,2)](https://www.ccrwest.org/cover/t_pages/t2/k6/C_96_6_2.html) are all solved. C(36,6,2), C(46,6,2), C(51,6,2), C(61,6,2), C(81,6,2) are all unsolved. A solution may exist when mod 15 equals 1 or 6. [C(49,7,2)](https://www.ccrwest.org/cover/t_pages/t2/k7/C_49_7_2.html) is solved, the rows, columns, and toroidal diagonals of both squares below give the 56 lines needed. [C(91,7,2)](https://www.ccrwest.org/cover/t_pages/t2/k7/C_91_7_2.html) is also solved. C(43,7,2) and C(85,7,2) are unsolved. ![order 7 projective plane][2] [C(57,8,2)](https://www.ccrwest.org/cover/t_pages/t2/k8/C_57_8_2.html) and [C(64,8,2)](https://www.ccrwest.org/cover/t_pages/t2/k8/C_64_8_2.html) are solved. [C(73,9,2)](https://www.ccrwest.org/cover/t_pages/t2/k9/C_73_9_2.html) and [C(81,9,2)](https://www.ccrwest.org/cover/t_pages/t2/k9/C_81_9_2.html) are solved. [C(8,4,3)](https://www.ccrwest.org/cover/t_pages/t3/k4/C_8_4_3.html), [C(10,4,3)](https://www.ccrwest.org/cover/t_pages/t3/k4/C_10_4_3.html), [C(14,4,3)](https://www.ccrwest.org/cover/t_pages/t3/k4/C_14_4_3.html), [C(16,4,3)](https://www.ccrwest.org/cover/t_pages/t3/k4/C_16_4_3.html), [C(20,4,3)](https://www.ccrwest.org/cover/t_pages/t3/k4/C_20_4_3.html) are solved, and more where mod 6 equals 1 or 5: 22, 26, 28, 32, 34, 38, 40, 44, 46, 50, 52, 56, 58. [C(17,5,3)](https://www.ccrwest.org/cover/t_pages/t3/k5/C_17_5_3.html) and [C(26,5,3)](https://www.ccrwest.org/cover/t_pages/t3/k5/C_26_5_3.html) are solved. [C(22,6,3)](https://www.ccrwest.org/cover/t_pages/t3/k6/C_22_6_3.html) is solved, this is known as the [M22 graph](http://mathworld.wolfram.com/M22Graph.html). [C(26,6,3)](https://www.ccrwest.org/cover/t_pages/t3/k6/C_26_6_3.html) is solved. C(37,7,3) is unsolved. [C(11,5,4)](https://www.ccrwest.org/cover/t_pages/t4/k5/C_11_5_4.html), [C(23,5,4)](https://www.ccrwest.org/cover/t_pages/t4/k5/C_23_5_4.html), and [C(35,5,4)](https://www.ccrwest.org/cover/t_pages/t4/k5/C_35_5_4.html) are solved. [C(27,6,4)](https://www.ccrwest.org/cover/t_pages/t4/k6/C_27_6_4.html) is solved, C(42,6,4) is unsolved. [C(23,7,4)](https://www.ccrwest.org/cover/t_pages/t4/k7/C_23_7_4.html) is solved, the ternary Golay code. For small coverings, that's pretty much all that's known. I was surprised at how many cases were unsolved. Also, many of the solutions don't yet have good pictures. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=smallproj.gif&userId=21530 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Rx7uc.gif&userId=21530 Ed Pegg 2016-09-08T15:01:11Z https://community.wolfram.com/groups/-/m/t/1135996 A Road Map for Rivers ================= The goal of this project was to identify rivers on maps and satellite images, and to calculate each river's graph structure. We produced two functions: one will return a highlighting of all the water in a satellite image given a location entity, and the other will return the graph structure of the water in the related street map image of a given location entity. Both functions start by taking the related street map of a location entity and stripping the image of every color other than one light shade of blue. Let's use Seoul, South Korea as an example: ![enter image description here][1] ![enter image description here][2] waterhighlight[entity_] := Module[{streetmap, color, r, bluemap, mask, satmap}, streetmap = RemoveAlphaChannel@ FirstCase[ GeoGraphics[entity, GeoBackground -> "StreetMap"], _Image, $Failed, Infinity]; satmap = ImageResize[ RemoveAlphaChannel@ FirstCase[ GeoGraphics[entity, GeoBackground -> "Satellite"], _Image, $Failed, Infinity], ImageDimensions[streetmap]]; color = Apply[List, ColorConvert[Interpreter["Color"]["RGB 158 197 226"], "RGB"]]; r = If[ImageColorSpace[streetmap] != "RGB", ColorConvert[streetmap, "RGB"], streetmap]; bluemap = SetAlphaChannel[r, Binarize[r, (Norm[# - color] < .15) &]]; mask = Closing[#, 7] &@FillingTransform@Binarize@bluemap; HighlightImage[ satmap, {EdgeForm[{Red, AbsoluteThickness[1.5]}], FaceForm[{Red, Opacity[.2]}], mask}] ]; The first function takes the blue image and uses it as a mask to highlight the related satellite image. ![enter image description here][3] ![enter image description here][4] watergraph[entity_] := Module[{streetmap, color, r, bluemap, mask}, streetmap = RemoveAlphaChannel@ FirstCase[ GeoGraphics[entity, GeoBackground -> "StreetMap"], _Image, $Failed, Infinity]; color = Apply[List, ColorConvert[Interpreter["Color"]["RGB 158 197 226"], "RGB"]]; r = If[ImageColorSpace[streetmap] != "RGB", ColorConvert[streetmap, "RGB"], streetmap]; bluemap = SetAlphaChannel[r, Binarize[r, (Norm[# - color] < .15) &]]; mask = Closing[#, 7] &@FillingTransform@Binarize@bluemap; MorphologicalGraph@SkeletonTransform[mask] ]; The second function smooths out the blue image, takes it's skeleton, and uses that to calculate the graph structure. The end product really is a graph object, so one could play with it using Wolfram's graph functionality to get some interesting results. ![enter image description here][5] ![enter image description here][6] Since one of the original goals of the project was to identify whether or not an image contained a river, we did make an attempt. We tried to first cut up the satellite images, binarize them, and then sort the tiny images based on the percentage of black and white pixels. We did this because in a large number of the initial images we saw, the water was usually much darker than the surrounding area. However as we looked at more test cases, this method of classifying images became useless. Many pictures require different binarize thresholds, some rivers are actually lighter than their surroundings, they may even be indistinguishable from the background, cloud coverage either blocks the water or can even create dark spots on its own via shadows, rivers may appear too thin to be recognized as such, and so on. As the list of issues grew, we decided to use the street maps due to their reliability. The street maps may have gaps in the water due to bridges, but this can be largely solved with basic image processing. In the future, we would like to implement a random river generation function and find a way to accurately automate the classification of satellite images as: "river" or "not river" to make a training set. From there, you could probably train a neural network to identify rivers from satellite images. [Github][7] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=10658streetmap.png&userId=1081910 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=bluemap.png&userId=1081910 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=satellite.png&userId=1081910 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Highlighted.png&userId=1081910 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Skeleton.png&userId=1081910 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9925Graphstructure.png&userId=1081910 [7]: https://github.com/Mathfig Z D 2017-07-05T19:22:36Z https://community.wolfram.com/groups/-/m/t/2144114 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/386c7594-731f-4d37-9c3a-5b06d7d7036f Wolfram Education Programs 2020-12-21T16:30:04Z https://community.wolfram.com/groups/-/m/t/1382823 The goal of this project has been to explore NAND expressions and look for expressions equivalent to XOR. The Wolfram Language can already simplify XOR expressions with NANDs by using the following function but it only simplifies to a two level tree. By using more than two levels there is a possibility of finding a simpler version of three or four input XOR expressions. The reason that I chose to use NAND gates is that they are universal gates (any expression can be represented with a combination of NAND gates). Other universal gates like NOR would work but it seemed simplest to just stick with NAND to keep things consistent. `BooleanMinimize[Xor[a, b, c], "NAND"] // TreeForm` ![NAND simplification for XOR[a,b,c] in Tree Form][1] ## Two Input Trees ## The first thing I implemented was a recursive function that creates all of the different NAND trees possible with a given amount of NAND gates. It works by assuming that each NAND gate only has two inputs. From this it runs through the possibilities for the NAND gate configurations on each input. ![Nand Tree Logic][2] The code starts by defining the first case of the recursive function and then on the next gates it runs through the different combinations with tuples to generate all of the outcomes. It also creates NAND trees with half of the amount of NAND implemented and it doesn't know what to do with an odd amount of gates so "nandTreeCreate" was implemented to fix that by multiplying the input by two. Additionally it uses a new NAND function that get's rid of trivial cases that aren't worth computing (Ex. Xor[a, !a]). nand[a_, a_] := Null; nand[a_, ! a_] := Null; nand[! a_, a_] := Null; nand[a_, b_] /; OrderedQ[{a, b}] := Sow@Nand[a, b]; nand[a_, b_] := Null; nandTreeGenerate[0] := {a, b, c, ! a, ! b, ! c} nandTuples[list1_, list2_] := Replace[Reap[ Do[nand[a, b], {a, list1}, {b, list2}]], {{_, {x_}} :> x, _ :> {}}] nandTreeGenerate[ 0] := {a,b,c,!a,!b,!c}; nandTreeGenerate[nGates_] := nandTreeGenerate[nGates] = Module[{subtrees = nandTreeGenerate /@ Range[0, nGates - 1]}, Join @@ Table[nandTuples[subtrees[[i]], subtrees[[nGates - i]]], {i, 1, nGates - 1}] ] nandTreeCreate[nGates_] := nandTreeGenerate[nGates*2] This turned out to be an effective set of functions but it wasn't very useful since it only generates two input NAND trees and no simpler forms of XOR were found by running tests with this function. The following function was used to compare it to XOR. Select[nandTreeCreate[5], TautologyQ[Equivalent[Xor[a, b, c], #]] &] ##Multi-Input Tree Generation ## By inputting the amount of leaves into the recursive function, I was able to expand it in order to account for more than two input NAND gates. This uses the same general structure as the two input NAND generate function except it is based on integer partitions to find all of the different combinations. nand[arg_] := Nand[arg]; nand[args___] /; Equivalent[args] := Null; nand[args___] /; OrderedQ[{args}] := Nand[args]; nand[args___] := Null; nandTuples[l_] := (nand @@ #) & /@ Tuples[l] nandTreeGenerate[1] := {a,b,c]}; nandTreeGenerate[nLeaves_] := nandTreeGenerate[nLeaves] DeleteCases[Module[{subtrees = nandTreeGenerate /@ Range[1, nLeaves - 1]}, Join @@ ((nandTuples[subtrees[[#]] & /@ #] & /@ (IntegerPartitions[nLeaves - 1])) ], Null] This works super well but it's still computationally intensive and I figured out later that some of the logic must be wrong since it misses a couple of cases every once and awhile. It's still good for getting a basic idea of the different cases that come from different leaf counts though. ## Random Generation ## It seems that the best way to generate expressions computationally comes from random generation. This is because it can be stopped and started within a time limit even though it doesn't get every possible expression. In order to implement this I used a function that inserts either a NAND gate or a variable at a random spot within the expression. varlist = {\[FormalA], \[FormalB], \[FormalC]}; addSomething[ex_] := Module[{positions}, positions = Position[ex, _myNand, {0, Infinity}]; Insert[ex, RandomChoice[{.2, .7, .7, .7} -> Join[{myNand[]}, varlist]], Append[RandomChoice[positions], 1]] ] makeTree[nLeaves_] := ( (Last@NestList[addSomething, myNand[], nLeaves - 1]) /. myNand[] :> RandomChoice[varlist]) /. myNand -> Nor randTreeGenerate[nLeaves_, nTimes_] := makeTree /@ Table[nLeaves, nTimes] Although this is good for generating most functions, some cases become increasingly unlikely as it adds more terms. This makes it necessary to adjust the weights for NANDs and variables so that all of the cases have an equal chance of occurring. I didn't have enough time to find the right values so eventually I setup the weights as random integers so that it would have a good distribution for each of the different weight combinations. ##Visualizing the Data## At the end I made a couple of functions that could generate expressions for awhile and then put it in a form that's easy to analyze. There are two equivalents of the functions depending on if you want to input the iterations or the duration that it should run for. It also has the option to input what percentage of those expressions should use NOR gates if any variation is needed. Clear["Global`*"] counts = Table[0, {i, 0, 255}]; varlist = {a, b, c}; addSomething[ex_, nand_: 1, var_: 1] := Module[{positions}, positions = Position[ex, _myNand, {0, Infinity}]; Insert[ex, RandomChoice[{nand, var/3, var/3, var/3} -> Join[{myNand[]}, varlist]], Append[RandomChoice[positions], 1]] ] makeTreeNand[nLeaves_] := ( (Last@NestList[ addSomething[#, RandomInteger[{1, 20}], RandomInteger[{1, 20}]] &, myNand[], nLeaves - 1]) /. myNand[] :> RandomChoice[varlist]) /. myNand -> Nand makeTreeNor[nLeaves_] := ( (Last@NestList[ addSomething[#, RandomInteger[{1, 20}], RandomInteger[{1, 20}]] &, myNand[], nLeaves - 1]) /. myNand[] :> RandomChoice[varlist]) /. myNand -> Nor visualizeCount[leaves_, iterations_, Nand_] := Module[{tree, counts = Table[0, {i, 0, 255}], c}, Monitor[Do[ c = 100*N@i/iterations; tree = makeTreeNand[RandomInteger[{1, leaves}]]; counts[[FromDigits[Boole[BooleanTable[tree]], 2]]]++; , {i, 1, iterations * (Nand/100)} ], c]; Monitor[Do[ c = 100*N@i/iterations; tree = makeTreeNor[RandomInteger[{1, leaves}]]; counts[[FromDigits[Boole[BooleanTable[tree]], 2]]]++; , {i, 1, iterations * (1 - (Nand/100))} ], c]; Print[ListLogPlot[Sort[counts[[#]] & /@ Range[0, 254]] + 1]]; Print[ArrayPlot[ IntegerDigits[#, 2, 8] & /@ Flatten[Position[counts[[#]] & /@ Range[0, 254], 0] - 1], Mesh -> True, ColorRules -> {0 -> Red, 1 -> Darker@Green}]]; Print[Column[ FullForm /@ (FullSimplify[BooleanFunction[#, varlist]] & /@ Flatten[Position[counts[[#]] & /@ Range[0, 254], 0] - 1])]]; Print[BarChart[counts[[#]] & /@ Range[0, 254]]] ] visualizeWhile[leaves_, time_, Nand_: 100] := Module[{tree, c, start = UnixTime[]}, Monitor[ While[UnixTime[] < (start + (time*(Nand/100))), c = UnixTime[] - start; Do[tree = makeTreeNand[RandomInteger[{1, leaves}]]; len += 1; counts[[FromDigits[Boole[BooleanTable[tree]], 2]]]++;, {100}] ], c]; start = UnixTime[]; Monitor[ While[UnixTime[] < (start + (time*(1 - (Nand/100)))), c = UnixTime[] - start; Do[tree = makeTreeNand[RandomInteger[{1, leaves}]]; counts[[FromDigits[Boole[BooleanTable[tree]], 2]]]++;, {100}] ], c]; Print[ListLogPlot[Sort[counts[[#]] & /@ Range[0, 254]] + 1]]; Print[ArrayPlot[ IntegerDigits[#, 2, 8] & /@ Flatten[Position[counts[[#]] & /@ Range[0, 254], 0] - 1], Mesh -> True, MeshStyle -> {Black, Thick}, Background -> Black, ColorRules -> {0 -> Red, 1 -> Darker@Green}]]; Print[Column[ FullForm /@ (FullSimplify[BooleanFunction[#, varlist]] & /@ Flatten[Position[counts[[#]] & /@ Range[0, 254], 0] - 1])]]; Print[BarChart[counts[[#]] & /@ Range[0, 254]]] ] Because there are only three variables being used, the amount of possible truth tables is 256. The function uses a list to keep track of the amount of times each of those truth tables occurred and at the end it creates a logarithmic line plot and a histogram. This particular test ran for 12 hours or so. The logarithmic plot is shifted up one to make it easier to analyze the data. ![Random Expression Logarithmic Plot][3] ![Random Expression Histogram][4] It also formats the truth tables that weren't generated into an array plot and lists the equivalent expressions for each of those truth tables. ![Expressions not generated][5] Xor[a,b,c,And[a,b,c]] Not[Xor[a,b,c,And[a,b],And[a,b,c]]] Not[Xor[a,b,c,And[a,c],And[a,b,c]]] Not[Xor[a,b,c,And[b,c],And[a,b,c]]] Not[Xor[a,b,c]] Not[Xor[a,b,And[a,c],And[b,c],And[a,b,c]]] Not[Xor[b,c,And[a,b],And[a,c],And[a,b,c]]] Xor[a,c,And[a,b],And[b,c],And[a,b,c]] Xor[a,b,c] Xor[a,b,c,And[b,c],And[a,b,c]] Xor[a,b,c,And[a,c],And[a,b,c]] Not[Xor[a,b,c,And[a,b,c]]] ##Conclusion## From random generation I was able to deduce to a reasonable degree of certainty that it is impossible to generate an equivalent NAND expression that's simpler than the one the Wolfram Language generates for three input XOR gates. There are most likely equivalent expressions out there for four or more input XOR expressions but that proves to be very computationally intensive and time consuming. It is pretty interesting how some expressions require significantly more NAND gates to be expressed because of their structure and the nature of NAND gates. It would be interesting to look into making expressions with NOR and XOR gates in the future and maybe putting more time into generating random expressions. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Capture2.PNG&userId=1371737 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Tree.png&userId=1371737 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Capture1.PNG&userId=1371737 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Capture3.PNG&userId=1371737 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Capture.PNG&userId=1371737 Ben Huenemann 2018-07-13T17:54:42Z https://community.wolfram.com/groups/-/m/t/1732378 ![enter image description here][1] (more graphs in sample graphs section) ## Introduction ## Phylogenetic trees are meant to show evolutionary relationships between species, and versions exist that show historical developments of programming languages. However, these relationships are limited in terms of showing how similar syntaxes are of different languages. This project's goal was to develop graphs that show relationships between computer languages, that are based off of syntactical factors instead of historical factors. Such graphs would be valuable because in addition to showing similarities between languages, they could provide insight on the order that would be easiest for learning new languages. It also would give more insight into the potential of machine learning to determine such relationships. ##Collecting and Saving the Data## Rosetta Code is a website with a list of coding tasks and their implementations in different languages. The advantage in the website is that languages can be directly compared for the same programs. It is the only data source for this project, and for programs that have more than one solution for the same language, the first language is used. The following functions are defined that will be able to scrape the programs off of the Rosetta Code website. To save time by not having to import anything more than once, the importOneTime function is defined so that values can be saved. importOneTime[args___] := importOneTime[args] = Import[args]; First, a list of all languages is obtained by parsing the html on the Rosetta Code languages page. allLanguages = Sort@ Select[ importOneTime[ "http://rosettacode.org/wiki/Category:Programming_Languages", "Hyperlinks"], StringMatchQ[#, "http://rosettacode.org/wiki/Category:*"] && ! StringMatchQ[#, "*Programming*" | "*Languages*" | "Encyclopedia*" | "*Cach*"] &] /. x_String :> StringReplace[x, "http://rosettacode.org/wiki/Category:" -> ""]; The Rosetta Code website has each language spelled in a specific way, but there are some exceptions, so the following additions are made to help when extracting code in case the user mistypes the language name. Specific user inputs are now treated as the correct spelling. languageTag[lang_String] := ToLowerCase[StringReplace[StringReplace[lang, "_" -> " "], {"c++" | "C++" -> "cpp", "#" -> "sharp", "Common Lisp" -> "Lisp", "Liberty Basic" -> "lb", "Objective C" -> "objc", "BASIC" -> "qbasic", "UNIX Shell" -> "bash", "Visual Basic" -> "vb", " " -> "", "/" -> "", "-" -> ""}]]; Extracting code will require comparing positions of values in a tree, where positions are described by lists. The following function is defined to compare tree-traversal lists, element-by-element, and to stop as soon as it finds a difference, picking the higher one. posGreater[a_List, b_List] := Module[{i}, i = 1; While[a[[i]] === b[[i]] && i < Min[Length[a], Length[b]], i = i + 1]; Return [a[[i]] > b[[i]]]] The extractCode function is now defined, and it works by parsing the html on a given Rosetta Code problem page to get the program for a given language. Not every language has the same html surrounding its program, so the function checks for multiple cases. extractCode[path_, language_] := StringTrim[Block[{langPos, langhead, allheads, nexthead, codeText, codeXML, pageXML}, (*Retrieves the XML*) Echo[pageXML = importOneTime[path, "XMLObject"] /. XMLElement[tag_, b___] :> XMLElement[ToLowerCase[tag], b], "xml"]; langPos = Position[pageXML, "class" -> languageTag[language] <> " highlighted_source"]; If[Length[langPos] >= 1, (*Code was correctly tagged, can be extracted*) codeXML = Extract[pageXML, #[[;; -3]]][[3]] & /@ langPos, (*Code was incorrectly tagged, requires further searching*) langhead = Position[pageXML, XMLElement["h2", _, cts_] /; MemberQ[cts, language, \[Infinity]]]; (*Look for a section heading containing the language's name*) If[Length[langhead] == 1, langhead = First[langhead]; (*Search for all section headings*) allheads = Sort[Position[pageXML, XMLElement["h2", _, _]]]; nexthead = allheads /. {{a___, langhead} -> \[Infinity], {a___, langhead, n_, b___} -> n}; (*Extract all XML tagged with generic source code tag between the two section heads*) codeXML = Extract[pageXML, Select[Position[pageXML, XMLElement["pre", {"class" -> "text highlighted_source"}, source_]], posGreater[#, langhead] && posGreater[nexthead, #] &] ]; , codeXML = ""; ]]; (*Convert the extracted XML to text*) Apply[StringJoin, codeXML //. { XMLElement["pre", {"class" -> "text highlighted_source"}, source_] -> source, XMLElement["br", _, _] -> "\n", XMLElement[_, _, {text___}] -> text} ]]] Sometimes a task is listed for a given language on the Rosetta Code page but it ends up being empty. For this reason, a simple function is created to count the characters of a program, and it will be used to filter out any empty programs. characterCount[str_] := StringLength[ StringReplace[str, {"\n" -> "", " " -> "", "\t" -> ""}]]; Now, parsing the html for a given programming language allows for the generation of a list of all tasks on Rosetta Code which have a solution written in that language. The function gets a list of every task for a language, using the characterCount function to filter out any empty programs. getCompletePageList[language_String] := Module[{links}, links = Cases[ DeleteCases[ importOneTime[ "http://rosettacode.org/wiki/Category:" <> StringReplace[language, " " -> "_"], "Hyperlinks"], x_String /; (StringMatchQ[x, StringExpression[ "*Category*" | "*Reports:*" | "*Rosetta_Code*" | "*Language_Comparison_Table*" | "*Help:*" | "*User:*" | "*Special:*" | ("*" <> StringReplace[language, " " -> "_"])]])], x_String /; StringMatchQ[x, "http://rosettacode.org/wiki/*"]]; Select[links, characterCount[extractCode[#, language]] >= 1 &]] Generating any graph will require the code for each language to be used as data, so this is imported once and saved. This list of lists is defined by iterating through every language and calling getCompletedPageList to find all links that have nonempty programs for the language on them. This contains all links that need to be used. Running this takes a long time, so the progress is monitored. Once finished, the data is saved. tasksForLang = Map[Monitor[getCompletePageList[#], #] &, allLanguages]; Future graphs will often be generated by using the top n most common languages on Rosetta Code, so now that the amount of programs per language is known, the following list can be ordered to rank all languages by how much data they have on Rosetta Code. As a list of tuples, it also contains the information of how many nonempty programs each language has. popularOrder = Reverse@SortBy[ Partition[Riffle[allLanguages, Map[Length[#] &, tasksForLang]], 2], #[[2]] &]; Now that all links are listed, a one-time extraction can be done from every single link to get the program. Since this takes a while, it is also monitored. The resulting programs are saved in a list of lists which has the same dimensions as taskForLang. codeForLang = Module[ {copyOfTasksForLang = tasksForLang}, Monitor[For[i = 1, i <= Length[tasksForLang], i++, For[j = 1, j <= Length[tasksForLang[[i]]], j++, copyOfTasksForLang[[i]][[j]] = extractCode[tasksForLang[[i]][[j]], allLanguages[[i]]] ] ], allLanguages[[i]]]; Return[copyOfTasksForLang] ]; Now the results are saved for future reference: DumpSave["RosettaCodeData.mx", {allLanguages, tasksForLang, codeForLang}]; ##Importing Saved Data## The saved data can be imported as generating it can take upwards of an hour. This file can be found in my GitHub repository [PhylogeneticGraphs][2] (https://github.com/mshundi/PhylogeneticGraphs). Clear[allLanguages, tasksForLang, codeForLang] Import["RosettaCodeData.mx"] ##Creating Functions that will be Used to Generate Graphs## The function that generates graphs will accept either an integer specifying the top n languages, a string of language names separated by spaces, or a list of languages. Three versions of the same function are written -- one for each type of input -- and in case the input is first validated. If the input is invalid, default values are used instead. This pair of functions calculates the top n programs based on amount of data, and rounds up if there are any ties. hasAtLeastNPrograms[n_] := Length[Select[popularOrder, #[[2]] >= n &]]; thresholdForTopNPrograms[n_] := Module[{m = 0}, While[hasAtLeastNPrograms[m] > n, m++]; Return[m]]; These functions calculate what languages will be used based on the input of the user. Each has the same name but a different input type so it can easily be called. languageGenerator[n_Integer] := Module[{m}, If[n < 2, m = 2, m = n]; machineLearningLanguages = programlistofpopularityn[thresholdForTopNPrograms[m]]]; languageGenerator[n_String] := machineLearningLanguages = StringSplit[n]; languageGenerator[n_List] := machineLearningLanguages = n; This function is made to get the first n programs for a language and it will be used when selecting programs to add to the dataset. firstNForLang[n_Integer, lang_String] := Take[codeForLang[[ Position[allLanguages, lang][[1]][[1]] ]], n] When a matrix is generated of all languages that get confused for one another, this function will return a list of edges represented as ordered triples, with the third element representing the weight of the edge. It then returns all edges whose weights are at least at a specified threshold, while not exceeding the upper limit for the threshold. weightedEdges[n_, langs_, matrix_] := Module[{list = {}, sorted = Sort[langs], returnedList}, For[i = 1, i <= Length[langs], i++, For[j = i + 1, j <= Length[langs], j++, AppendTo[list, {sorted[[i]], sorted[[j]], matrix[[j]][[i]]}]; AppendTo[list, {sorted[[j]], sorted[[i]], matrix[[i]][[j]]}] ]]; (*Edges are reverse sorted by weight in case weak ones need to be trimmed off*) returnedList = Select[ReverseSortBy[list, #[[3]] &], #[[3]] >= n &]; (*Errors occur when passing this limit, so the excess, weak edges are trimmed*) If[Length[returnedList] >= 896, returnedList = returnedList[[;; 896]], returnedList = returnedList ]; Return[returnedList] ] Now the function that will ultimately make a graph when given the necessary input is created. This takes in a threshold, a graph layout, a list of all languages that will be included on the graph, and the confusion matrix from the machine learning testing. It calls weightedEdges to get a list of edges to use. The results are used to create a graph where the thickness of an edge linearly corresponds to its weight. These weights are just how often two languages get confused for each other. An arrow on the graph going from A to B means that B gets mistaken as A, meaning that B is similar and would be easier to learn if one already knows A. graphAnEdgeList[n_, layout_: Automatic, langs_, matrix_] := Module[{weights = {}, edge = {}, edges = weightedEdges[n, langs, matrix]}, Map[AppendTo[weights, #[[3]]/5000.0] &, edges]; Map[AppendTo[edge, #[[2]] -> #[[1]]] &, edges]; Graph[langs, edge, EdgeStyle -> Thread[edge -> (Thickness[#] & /@ weights)], VertexLabels -> "Name", GraphLayout -> layout] ]; ##Making the Graphing Functions## Two functions are made, one which outputs a manipulable graph and one which outputs a static graph. For the manipulable graph, the input will be one parameter: either an integer denoting the top n languages, a string of space-separated languages, or a list of languages. The output will be a manipulable graph where the user will be able to change the threshold for edges that are included and change the graph layout. The following well-documented function is used to create the manipulable graph. phylogeneticGraph[languagestoinclude_] := Module[{machineLearningLanguages = {}, programsToUsePerLanguage, datasetPrograms, dataset, matrixValues, minThresh, dataTraining, dataTesting, dataClassifier, dataClassifierTesting}, (*Generates the list of languages to use based on user input*) machineLearningLanguages = languageGenerator[languagestoinclude]; (*Display errors sometimes occur at high numbers and low thresholds, so the minimum threshold is adjusted based on how many languages \ are being used*) If[Length[machineLearningLanguages] > 50, minThresh = 3, minThresh = 1]; (*Finds the minimum amount of data that any of the programs being \ used has, and uses that number as the amount of tasks to use for each \ language when making the dataset.*) programsToUsePerLanguage = Min[Map[ Length[tasksForLang[[Position[allLanguages, #][[1]][[1]]]]] &, machineLearningLanguages]]; (*Makes a list of lists of all programs to use for the dataset by \ picking the same amount from each, which was calculated in programsToUsePerLanguage*) datasetPrograms = Map[firstNForLang[programsToUsePerLanguage, #] &, machineLearningLanguages]; (*Creates a 2-column dataset of language and program. These are taken directly off of datasetPrograms*) dataset = Association @@@ Flatten[Map[Table[{"code" -> datasetPrograms[[ Position[machineLearningLanguages, lan][[1]][[1]]]][[#]], "language" -> lan}, {lan, machineLearningLanguages}] &, Range[programsToUsePerLanguage]], 1] // Dataset; (*Splits the dataset into training data and testing data in a ratio \ of 1 to 2*) {dataTraining, dataTesting} = TakeDrop[dataset, Round[Length[dataset]/3]]; (*Creates a classifier based on predicting the language given the \ code, training it and testing it on the designated parts of the data \ set*) dataClassifier = Classify[dataTraining -> "language", PerformanceGoal -> "Speed"]; dataClassifierTesting = ClassifierMeasurements[dataClassifier, dataTesting -> "language"]; (*Gets a confusion matrix based on wrong classifications made by \ the classifier. It will be used as the basis of generating the graph*) matrixValues = dataClassifierTesting[{"Precision", "ConfusionMatrix"}][[2]]; Length[weightedEdges[1, machineLearningLanguages, matrixValues]]; (*Makes a Manipulable graph where the user can change the layout \ and threshold. The minimum threshold is determined based on the amount of \ languages and the maximum threshold is determined based on the \ strength of the strongest edge*) Manipulate[ graphAnEdgeList[threshold, layout, machineLearningLanguages, matrixValues], {threshold, minThresh, weightedEdges[1, machineLearningLanguages, matrixValues][[1]][[3]], 1}, {layout, {Automatic, "BipartiteEmbedding", "CircularEmbedding", "CircularMultipartiteEmbedding", "DiscreteSpiralEmbedding", "GridEmbedding", "LinearEmbedding", "MultipartiteEmbedding", "SpiralEmbedding", "StarEmbedding"}}]] For example, using the function to give a manipulable graph for the top 25 languages gives: phylogeneticGraph[25] ![enter image description here][3] To make a static graph, this function essentially does the same thing as the previous function, but instead of outputting a manipulable graph, it only gives one static graph. Because it doesn't allow the user to change parameters once the graph is generated, it takes in the arguments for threshold and layout as inputs. staticPhylogeneticGraph[languagestoinclude_, threshold_Integer, layout_String] := Module[ {machineLearningLanguages = {}, programsToUsePerLanguage, datasetPrograms, dataset, matrixValues, minThresh, dataTraining, dataTesting, dataClassifier, dataClassifierTesting}, (*Generates list of languages to use based on user input*) machineLearningLanguages = languageGenerator[languagestoinclude]; (*Display errors sometimes occur at high numbers and low thresholds, due to having too many branches, so the minimum threshold is adjusted based on how many languages \ are being used.*) If[Length[machineLearningLanguages] > 50, minThresh = 3, minThresh = 1]; (*Finds the minimum amount of data that any of the programs being \ used has, and uses that number as the amount of tasks to use for each \ language when making the dataset.*) programsToUsePerLanguage = Min[Map[ Length[tasksForLang[[Position[allLanguages, #][[1]][[1]]]]] &, machineLearningLanguages]]; (*Makes a list of lists of all programs to use for the dataset by \ picking the same amount from each, which was calculated in programsToUsePerLanguage*) datasetPrograms = Map[firstNForLang[programsToUsePerLanguage, #] &, machineLearningLanguages]; (*Creates a 2- column dataset of language and program in cycling order of form. These are taken directly off of datasetPrograms*) dataset = Association @@@ Flatten[Map[Table[{"code" -> datasetPrograms[[ Position[machineLearningLanguages, lan][[1]][[1]]]][[#]], "language" -> lan}, {lan, machineLearningLanguages}] &, Range[programsToUsePerLanguage]], 1] // Dataset; (*Splits the dataset into training data and testing data in a ratio \ of 1 to 2*) {dataTraining, dataTesting} = TakeDrop[dataset, Round[Length[dataset]/3]]; (*Creates a classifier based on predicting the language given the \ code, training it and testing it on the designated parts of the data \ set*) dataClassifier = Classify[dataTraining -> "language", PerformanceGoal -> "Speed"]; dataClassifierTesting = ClassifierMeasurements[dataClassifier, dataTesting -> "language"]; (*Gets a confusion matrix based on wrong classifications made by \ the classifier. It will be used as the basis of generating the graph*) matrixValues = dataClassifierTesting[{"Precision", "ConfusionMatrix"}][[2]]; Length[weightedEdges[1, machineLearningLanguages, matrixValues]]; (*Generates the static graph by calling graphAnEdgeList*) graphAnEdgeList[minThresh + Abs[threshold], layout, machineLearningLanguages, matrixValues]] To see a low-threshold graph for top 15 languages in a circular display: staticPhylogeneticGraph[15, 1, "CircularEmbedding"] ![enter image description here][4] ##Summary of Results## The final product is functions that generate graphs for a list of languages, showing all connections having strength above a specified threshold, and having the thickness of edges correspond to their strengths. Relationships between programming languages were determined by how often a machine learning classifier would confuse languages for each other. On the graph, an arrow from A to B means that B gets confused for A, and someone who knows language A would therefore find it easier to learn language B. Few pairs of languages exist that have strong connections going both ways. All data used came from Rosetta Code, which provides tasks written in different program languages. Individual programs were scraped off of the website by using Mathematica to parse the HTML. This data was saved once extracted, as there were close to 1,000 languages and almost 1,000 unique programming tasks. A data set would be made with programs of all languages that were going to be in the graph. The benefit of using Rosetta Code was that most of the data was of programs doing the same task but coded in different languages. A machine learning classifier would train and test on parts of the data, and confusion between languages would indicate a relationship, with higher amounts of confusion corresponding to a stronger relationship. The are two main functions: one that creates a manipulable graph and one which creates a static graph. Both take in either an integer representing the top n languages or a string of space-separated languages. This determines what languages to include in the graph. The manipulable graph allows the user to change the threshold of the edge strength and the graph layout, while the static graph requires that these two are passed as parameters beforehand. The results do have some limitations. While the overall data size was relatively large, it still represents a tiny subset of all available programs. Additionally, only Rosetta Code was used as a data source, and its programs are relatively short in length. While the code itself does work, it can also likely be cleaned up, and its performance can probably be improved. In terms of using charts for deciding what languages to learn, the arrows might not tell the full story. A strong arrow from A to B might indicate that knowledge of A benefits one most in learning B, but it doesn't necessarily mean that B is the easiest to learn. It's still possible that there are languages completely unrelated to A which are still easier to learn than B. While the graphs should be considered, they don't provide information on the general complexity of a language or how easy or difficult it is to migrate to that language. ##Sample Graphs## The following sample graphs are shown for the top n programs and for each n, multiple graphs are given with varying thresholds for minimum edge strength. Arrows from A to B indicate that B gets confused for A and that knowing A would make it easier to learn B. Top 5 Languages: High Threshold ![enter image description here][5] Top 5 Languages: Low Threshold ![enter image description here][6] Top 10 Languages: High Threshold ![enter image description here][7] Top 10 Languages: Low Threshold ![enter image description here][8] Top 15 Languages: High Threshold ![enter image description here][9] Top 15 Languages: Medium Threshold ![enter image description here][10] Top 15 Languages: Low Threshold ![enter image description here][11] Top 20 Languages: High Threshold ![enter image description here][12] Top 20 Languages: Medium Threshold ![enter image description here][13] Top 20 Languages: Low Threshold ![enter image description here][14] Top 30 Languages: High Threshold ![enter image description here][15] Top 30 Languages: Low Threshold ![enter image description here][16] Top 50 Languages: High Threshold ![enter image description here][17] Top 50 Languages: Low Threshold ![enter image description here][18] Top 100 Languages: High Threshold ![enter image description here][19] Top 100 Languages: Low Threshold ![enter image description here][20] ##Future Explorations## The results from the generated graphs were reasonable and promising, suggesting that similar methods could be used for larger datasets and fields. While the historical influences of programming languages on each other are relatively well known, this could potentially help in finding relationships in writing, music, and even art, both in the past and in the present. Machine learning is capable of handling larger amounts of data than what is available with computer languages, and it would likely scale well for these broader fields. ##Links to Data## The full notebook and extracted code can be found in my GitHub repository [PhylogeneticGraphs][21]. All data can be found at [Rosetta Code][22]. ##Acknowledgements## Thank you to my mentor, Nikki Sigurdson, and to everyone -- including Mads Bahrami, Philip Maymin, Christian Pasquel, and more -- at the 2019 Wolfram Summer Camp who helped teach me the Mathematica language and worked with me on coding and debugging. Also a big thank you to Stephen Wolfram and all of the organizers for organizing the camp and providing me with this opportunity. Thank you to Jon McLoone for showing how to extract code from the Rosetta Code website in his blog on comparing code lengths [Code Length Measured in 14 Languages][23], and thank you to [Rosetta Code][24] and its contributors for providing all of the data. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WolframFinalPresentation.png&userId=1724884 [2]: https://github.com/mshundi/PhylogeneticGraphs [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.29.13PM.png&userId=1724884 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.26.49PM.png&userId=1724884 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.45.37PM.png&userId=1724884 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.45.46PM.png&userId=1724884 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.46.43PM.png&userId=1724884 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.46.49PM.png&userId=1724884 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.47.35PM.png&userId=1724884 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.48.14PM.png&userId=1724884 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.48.25PM.png&userId=1724884 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.49.52PM.png&userId=1724884 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.50.07PM.png&userId=1724884 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.50.18PM.png&userId=1724884 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.53.16PM.png&userId=1724884 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.52.43PM.png&userId=1724884 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.52.26PM.png&userId=1724884 [18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.52.08PM.png&userId=1724884 [19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.51.41PM.png&userId=1724884 [20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at8.51.31PM.png&userId=1724884 [21]: https://github.com/mshundi/PhylogeneticGraphs [22]: http://rosettacode.org/wiki/Rosetta_Code [23]: https://blog.wolfram.com/2012/11/14/code-length-measured-in-14-languages [24]: http://rosettacode.org/wiki/Rosetta_Code Matias Shundi 2019-07-12T01:15:23Z https://community.wolfram.com/groups/-/m/t/1120587 #Cross post [here](https://mathematica.stackexchange.com/questions/144550/how-to-find-a-longest-word-path-in-dictionary) ---------- A word path means the last character of the last word is same to the first character of the next word.If I have $55$ words,I can find it with this method. ###Build a graph SeedRandom[2] string = Select[ToLowerCase[RandomSample[DictionaryLookup[]]], 3 < StringLength[#] < 5 &]; g = RelationGraph[StringTake[#, -1] == StringTake[#2, 1] &, string[[;; 55]], VertexLabels -> "Name"]  ###Find a longest word path by [Jason](https://mathematica.stackexchange.com/users/9490/jason-b)'s answer [here](https://mathematica.stackexchange.com/a/136278/21532) allPaths = FindPath[g, #2, #1, Infinity, All] & @@@ Subsets[VertexList[g], {2}] // Apply[Join]; First[TakeLargestBy[allPaths, Length@Union@# &, 1]] >`{calm,muir,reef,fray,yaws,seed,deaf,fnma,axis,stow,waft,tint,trig,good,duns,sill,loge,etch,hill,lath,howl}` Well I have to say this is a very very slow solution.I even cannot find more than $60$ words.Actually I want to find `Length[DictionaryLookup[]]=92518` words. It seem I still have a long way to go.Do any suggestion can give? Yode Japhe 2017-06-15T01:31:44Z https://community.wolfram.com/groups/-/m/t/1383122 ![enter image description here][1] #Project Description Graph coloring is an NP-complete problem that asks for the minimum number of colors required to color a graph such that no two adjacent vertices can have the same color. Because this is such a well-known topic, a lot of research has been done on it. However, not much study has been done on fractional colorings, which is simply a generalized graph coloring. What makes the fractional coloring problem complicated is that in addition to the problem constraint, each vertex is assigned a list of colors. So, the problem statement is as follows: "What is the minimum number of colors such that no two adjacent vertices have any colors in common?" Because each vertex can have varying number of colors, the infamous problem of fractional graph coloring is NP-complete. However, it can be reasonably approached through linear programming. In fact, the minimum real number to color a fractional graph while still satisfying the problem's constraints can be obtained as a solution to a linear program. In this project, I will be comparing two versions of the graph coloring problem: integral and fractional. ##Definitions $\textbf{Chromatic Number}$ [$\chi(G)$ , $\chi^F(G)$]: Minimum number of colors required to color a graph while satisfying the coloring problem's constraints. $\textbf{Chromatic Polynomial}$ [$P(G, z), P(G^F, z)$]: Polynomial of order $n$ that counts the number of colorings as a function of the number of colors. Therefore, the minimum value that makes the function positive is the chromatic number. $\textbf{a:b-coloring}$: Coloring that uses $a$ available colors to color a graph with $b$ vertices. $\textbf{Graph Homomorphism}$: Mapping between two graphs that respects their structure. $\textbf{Vertex-transitive graph}$: Graph such that every pair of vertices is equivalent under some element of its automorphism group. ##Basic Methods Below are the elementary methods purely pertaining to graph colorings: ValidColoring[g_, c_] := AllTrue[Table[ Intersection[{c[[i]]}, c[[AdjacencyList[g, i]]]] == {}, {i, 1, VertexCount[g]}], TrueQ]; ChromaticNumber[g_] := MinValue[{z, z > 0 && ChromaticPolynomial[g, z] > 0}, z, Integers]; The $\textit{ValidColoring}$ method ensures that the current list of colors satisfies the problem's constraint that no two adjacent vertices can have the same colors. It does so by checking that there are no intersections between each pair of adjacent vertices. The $\textit{ChromaticNumber}$ method goes through all integer values that make the chromatic polynomial of a graph positive and takes the minimum out of those values. ##Fractional Colorings in Terms of Independent Sets $I(G)$: set of all independent sets of vertices in $\textit{V(G)}$ $\textit{I(G,u)}$: set of all independent sets of vertices containing the vertex $u$ In this context, a fractional coloring is a mapping $f$: $I(G) \rightarrow$ [0, 1] with the property that, for every vertex $u$, $\sum_{J \in I(G,u)} f(J) \ge 1$. Then, the sum of the function values over all independent sets is called the weight of the fractional coloring. Therefore, the fractional chromatic number is the infimum of all the sums of the fractional coloring weights. To see the connection between fractional colorings and independent sets, one must note that each color class is an independent set belonging to $I(G)$. Then, define $f$: $I(G) \rightarrow$ [0, 1], mapping each color class to 1 and every other independent sets to 0. Next, suppose that a graph $G$ has a proper a:b-coloring. In this case, if one defines a function that sends each color class to $\frac{1}{b}$ and every other independent set to 0, it is true that $\sum_{J \in I(G,u)} f(J) = 1$ for every vertex $u$, which then leads to a fractional coloring with weight $\frac{a}{b}$. ##Linear Programming Formulation Below are the methods used to compute the fractional chromatic number: independentSets[G_] := FindIndependentVertexSet[G, Infinity, All] A[is_, G_] := Table[If[MemberQ[is[[i]], j], 1, 0], {i, Length[is]}, {j, VertexCount[G]}] OneVector[N_Integer] := Table[1, N] y[one_, A_, R_] := LinearProgramming[one, Transpose[A], R] From the relationship between chromatic numbers and independent sets, one can formulate a matrix $A(G)$ such that its columns are indexed by $V(G)$ and that its rows are indexed by $I(G)$. When formulating this matrix, entries are 1 if they are in the independent set represented by the column and 0 if they are not. Doing so essentially gives a characteristic function of the vertices' corresponding independent sets. Next, make a variable vector $y(G)$ that is indexed by $I(G)$. Then, the task reduces to minimizing the sum of the variables in the vector $y(G)$ (weighted coloring of graphs), subject to the set of constraints that each entry in $y(G)^T A(G) \ge 1$ and that all elements in $y(G)$ fall in the interval [0, 1]. ##Coloring the Graph ###Idea The $k$-fold chromatic number is given by $\chi(G) = \frac{1}{k}\chi(G')$, where $G'$ has each vertex in $G$ replaced with $k$ copies, and each edge $(u',v')$ in $G'$ is formed if the original vertices of both $u'$ and $v'$ in $G$ are the same or incident. This transformation is called **strong graph product**, which 'decomposes' each vertex into a complete graph $K_{k}$,while maintaining the overall structure of $G$. After coloring $G'$, group back all vertices that belong to the same 'super-vertex', which will lead $G$ to have multiple colors contributed by the sub-vertices in $G'$. ###Methods explodeGraph[g_, 1] := g explodeGraph[g_, k_] := Graph[Union @@ newEdges[k] @@@ EdgeList[g]] newEdges[k_][v1_, v2_] := With[{nv1 = Thread[{v1, Range[k]}], nv2 = Thread[{v2, Range[k]}]}, UndirectedEdge @@@ Join[ Tuples[{nv1, nv2}], Subsets[nv1, {2}], Subsets[nv2, {2}] ] ] mapping[n_, g_, vstyle_, newmapping_] := Sort[Table[{newmapping[vstyle[[i]][[1]]], vstyle[[i]][[2]]}, {i, Length[vstyle]}]] FractionalColoring[n_Integer, m_Integer, cmaplist_] := Table[Graphics[{EdgeForm[Black], Table[{cmaplist[[z]][[k]], Disk[{0, 0}, 1, {-\[Pi]/2 + 2 \[Pi]*(k - 1)/m, -\[Pi]/2 + 2 \[Pi]*k/m}]}, {k, 1, m , 1}]}], {z, 1, n, 1}] Example with a cycle graph of 5 vertices ($C_{5}$): ![Strong graph product example][2] ##Special Graphs ###Cycle Graph Denoted by $C_{n}$, a cycle graph is a graph on $n$ nodes containing a single cycle through all nodes. Below is a cycle graph with 8 vertices. ![enter image description here][3] In a cycle graph, it is quite obvious that $i)$ if there are even number of vertices, then the chromatic number is 2, and $ii)$ if there are odd number of vertices, then the chromatic number is 3. However, fractional graph coloring is slightly different. Although $\chi(G) = \chi^F(G)$ for even cases, that is not true for odd cases. In fact, $\chi^F (C_{2n + 1}) = 2 + \frac{1}{n}$. The fractional chromatic number in a cycle graph must be greater than 2 because four "one-half" colors must be used in any vertex triplets. Below is an example of 5:2-coloring of a cycle graph. ![enter image description here][4] ###Kneser Graph In a Kneser graph $K_{a:b}$, the vertices are $b$-element subsets of a fixed set $\{1, 2, ...., a\}$ and the edges exist between the vertices if and only if the subsets represented by them are disjoint. Therefore, by definition, if $b$ = 1, the graph becomes $K_{a}$, which is a complete graph with a vertices. The connection between graph coloring and graph homomorphism is that a graph is a:b-colorable if and only if there is a homomorphism $\phi : G \rightarrow K_{a:b}$. **Erdos-Ko-Rado Theorem** states that: if $a$ and $b$ are positive integers with $a \ge 2b$, then independence number $\alpha(K_{a:b}) = {a-1\choose b-1}$. It is true that for any graphs, $\chi^F(K_{a:b}) \ge \frac{|V(K_{a:b})|}{\alpha(K_{a:b})}$. In the special case where the graph is vertex-transitive, $\chi^F(K_{a:b}) = \frac{|V(K_{a:b})|}{\alpha(K_{a:b})}$. Since there are ${a\choose b}$ vertices in a Kneser graph, $\chi^F(K_{a:b}) = \frac{{a\choose b}}{{a-1\choose b-1}} = \frac{a}{b}$. ##Demonstration Below is the code for the Manipulate function that compares integral and fractional graph colorings: Manipulate[ Module[{graph, graph2, chrom, colorings, sol, palette, cg, vL, fracColoring, is, matrix, yV, fracChrom, fracG, vlist, map, fracC, vstyle, newvl, newmapping, cmap, cmaplist}, SeedRandom[s]; graph = RandomGraph[{n, m}, VertexSize -> Medium]; graph2 = graph; (* Integral Coloring *) vL = VertexList[graph]; chrom = ChromaticNumber[graph]; colorings = Tuples[Table[i, {i, 1, chrom}], VertexCount[graph]]; sol = SelectFirst[colorings, ValidColoring[graph, #] &]; palette = discreteColors[chrom]; Do[PropertyValue[{graph, v[[1]]}, VertexStyle] = v[[2]], {v, Table[{i, palette[[sol[[i]]]]}, {i, 1, VertexCount[graph]}]}]; (*Fractional Coloring *) fracG = explodeGraph[graph2, 2]; vlist = VertexList[fracG]; newmapping = Association[ Table[2*(vlist[[i]][[1]] - 1) + vlist[[i]][[2]] -> vlist[[i]][[1]], {i, Length[vlist]}]]; newvl = Table[2*(vlist[[i]][[1]] - 1) + vlist[[i]][[2]], {i, Length[vlist]}]; fracG = Graph @@ ({vlist, EdgeList[fracG]} /. Thread[vlist -> newvl]); fracC = brelaz[fracG]; vstyle = MapIndexed[First[#2] -> ColorData[61, #1] &, fracC]; map = mapping[2, fracG, vstyle, newmapping]; cmap = Table[map[[i]][[2]], {i, Length[map]}]; cmaplist = Table[cmap[[2*(i - 1) + j]], {i, 1, VertexCount[fracG]/2}, {j, 1, 2}]; fracColoring = FractionalColoring[VertexCount[graph2], 2, cmaplist]; is = independentSets[graph]; matrix = A[is, graph]; yV = y[OneVector[Length[is]], matrix, OneVector[VertexCount[graph]]]; fracChrom = Total[yV]; Row[ {Column[{ Row[{Style["Integral Graph", Bold, RGBColor[0., 0.79, 0.76], 40, FontFamily -> "Baskerville"]}], Row[{Style["Integral Chromatic Number: ", 15], Style[chrom, 20] }], Graph3D[graph, ImageSize -> {400, 400}, EdgeStyle -> RGBColor[0.8, 0.8, 0.8]] }, Center, 5], Column[Table["|", {t, 1, 35}]], Column[{ Row[{Style["Fractional Graph", Bold, RGBColor[0., 0.94, 0.33], 40, FontFamily -> "Baskerville"]}], Row[{Style["Fractional Chromatic Number: ", 15], If[fracChrom < chrom, Style[fracChrom, 20, Bold, Pink], Style[fracChrom, 20]]}], Graph[graph2, ImageSize -> {400, 400}, VertexShape -> Thread[VertexList[graph2] -> fracColoring], EdgeStyle -> RGBColor[0.8, 0.8, 0.8]] }, Center, 5]}, " " ] ], {{n, 3, "Number of Vertices"}, 3, 7, 1, Appearance -> "Labeled"}, {{m, 3, "Number of Edges"}, 3, n*(n - 1)/2, 1, Appearance -> "Labeled" }, {{s, 1, "Random Seeding"}, 1, 10000, 1, Appearance -> "Labeled"}, SaveDefinitions -> True ] ![enter image description here][5] ##Future Work First of all, the coloring process needs to be drastically optimized. Because the current algorithm is extremely slow, it cannot color a graph with more than 7 vertices. Initially, I hoped that I would be able to handle at least 100 vertices, but I realized that coloring a graph is not easy as it seems like. With further optimization, I hope to improve this project so that it can efficiently compute both integral and fractional chromatic number and optimally color both integral and fractional graphs almost instantly. Second of all, I wanted to explain the relationships between different topics of graph theory and graph colorings, but I was not able to do so because I spent too much time trying to figure out how to color a fractional graph. For instance, one of the most surprising characteristic of fractional chromatic number is that it is equal to the fractional clique number. Rigorously proving the previous statement requires deep insight into properties and characteristics of both fractional clique number and chromatic number, so doing so would make me digress and talk about tangential topics. Lastly, I want to handle more complicated fractional graphs, such as the ones that have more than just 2 colors assigned to them. In this project, each vertex is assigned 2 colors each. However, I want to expand on this project by having varying number of colors in each vertex. Moreover, the algorithm is not exact because I used the Brelaz heuristic, which is just an approximation of the coloring. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-13at3.45.36PM.png&userId=1372296 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-13at2.31.56PM.png&userId=1372296 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4931ScreenShot2018-07-06at6.52.43PMSMALLER.png&userId=1372296 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-06at6.52.43PMSMALLER.png&userId=1372296 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=7158ScreenShot2018-07-06at6.52.43PMSMALLER.png&userId=1372296 Jongwan Kim 2018-07-13T19:24:33Z https://community.wolfram.com/groups/-/m/t/1379016 ![Twine Button Graph][1] # Wolfram-Twine Bridge The goal of the project was to build an Import/Export system between Twine Projects and the Wolfram Language. [Twine](http://twinery.org) is browser-based software used to make interactive stories and text-based games. One can think of a Twine story as a website, where each webpage is analogous to a passage in the story. Connections between passages can be as sparse or dense as you like. Essentially one has a network of passages. A nice way to represent a network is with a graph, this is one of the forms I use to represent a Twine Story in Mathematica. (There is a link to my code at the end of this post) ## Twine Structure The workspace for Twine projects is the Twine Editor, available [online](http://twinery.org/2/#!/welcome) and desktop. A published Twine file is in html format. This is the file we want to parse for import. Sample Twine file: ![Twine HTML Structure][2] The HTML structure is simple: ```html <tw-storydata> <tw-passagedata> "PASSAGE CONTENT ..." </tw-passagedata> <tw-passagedata> "PASSAGE CONTENT ..." </tw-passagedata> ... </tw-storydata> ``` Some published Twine Projects have other HTML information, though this is not necessary for Import or Export. All we need is whatever is within the `<tw-storydata>` tags. ## Import Procedure Initially, there were issues with importing the Twine files I had on hand. I presume it's because these files were not valid HTML (no doctype). The `XML` import did not work either, presumably for the same reason. Importing as `XMLObject` generated something that looked reasonable, but introduced an extraneous body tag in the middle of the structure. Riccardo Di Virgilio, an instructor at the summer school wrote a parser that takes in a string version of the file and outputs a properly nested XML structure. With the story data in XML form, I could start generating the Graph and Association representation. The first thing I did was look for the particular `Cases` of `XMLElement` patterns to extract the story title and passages. From there I used that data to construct a graph. Harlowe uses a pair of Double Square brackets to denote a link. To create the edges I defined two functions, ` generateEdges`, and `extractLinks`. `generateEdges` takes in the passage name and a list of links and creates a directed edge between the passage name and those links. The list of links is generated from `extractLinks`. `extractLinks` takes in a passage's content and extracts all string content within Double Square Brackets and puts them in a list. It's nice to have the graph, but there should be a quick way to see the content of each passage as well. I wrapped all the vertices of the generated graph with Tooltips so one can hover over them and see the passage content. To do this I made an association of the form `<|"Story Title" -> "Start Here", "First Passage" -> "First Passage Content", ..., "Last Passage" -> "Last Passage Content" |>`. Then I generate the output Association. The Import function outputs a list of the Tooltip Graph and the output Association. Example output: ![enter image description here][3] ## Export Procedure To export a Twine project I wrote `twineExport`. It takes an Association form of a story and exports it as an HTML fragment. One can then import it into the Twine Editor. Twine passages also have a position attribute which I'm trying to make use of to place them nicely in the Twine editor. The current thinking is to mimic the layout of vertices from the graph representation. (I use `twineSummary` function for this, I'll share that in the next section). I can use the `GraphEmbedding` function on the graph. `GraphEmbedding` returns the coordinates of the vertices, then I just need to scale the points to orient nicely in Twine. The Left Image shows the exported file. In the Right image, I moved the passages around to show what one would get with using `GraphEmbedding`. ![enter image description here][4] ![enter image description here][5] ## Summary Procedure The Twine Editor has a playthrough interface so one can test their stories. I haven't implemented something like this yet, but there is a simpler story explorer that I've made. The `twineSummary` function creates it. The function takes an association as its first argument and an optional string as its second argument. The default output without any options is a `GraphicsRow` where the first item is a dynamic passage viewer and the second item is a Button Graph. Each Button is a passage name; when clicked it will update the dynamic viewer with its respective content (An Image of this output is at the top of this post). "Graph" and "Export" are the possible options for `twineSummary`. "Graph" returns the Button Graph by itself. "Export" generates a Twine HTML file and saves it to a folder called `TwineStories` in the current notebook directory. ## Macros The default markup language for Twine, called [Harlowe](https://twine2.neocities.org), has syntax for macros: commands for changing story elements and states. I have yet to support these features but have been ideating a way to work with them. Let's look at the set macro as an example. To set the value of the variable `myNumber` to the value `10` we can write the following: `(set: $myNumber to 10)`. What I've been thinking is to use an association where the keys are `command` and `data`. For set it would look like this: `<|"command" -> "set", "data" -> <|"Variable" -> Symbol[$myNumber], "Value" -> 10 |>|>` I defined a function called macroGrammar to handle this command and some others. In the `set` case I generate a string representation of setting, for example, "var = val". Then convert that to an expression. ```Mathematica macroGrammar[macroAssoc_Association] := Module[{command = macroAssoc["command"], data = macroAssoc["data"]}, Switch[command, "set",ToExpression[ToString@data["Variable"] <> "=" <> ToString@data["Value"]] , "if", If[data["ConditionExpression"], data["T"], data["E"]], "print", Print[data], "either", RandomChoice[data] ] ] ``` A list of Harlow macros can be found [here](https://twine2.neocities.org/#macro_set) ## Future Directions I'd like to implement more macros. Among other types, there are conditional, printing, data and output macros. Some macros include Links to other passages, which I can't support yet as they are effectively hidden from my parser. In addition to this, I need to come up with a good Passage Positioning scheme for Import to Twine. The other thing to do on the Wolfram Language side is better placement of the Vertex Labels. So for large graphs, the labels don't overlap. A Twine workspace editor in Mathematica would be useful as well. As of now, one has to write the Association by hand. (of course one can always just use the Twine editor). The next step is to gradually implement these macros and continually increase the number of stories I am testing on. For each parsing or macro error in a story, I can implement a fix. My [TWINE CODE](https://github.com/dishmint/Summer2018Starter/blob/master/Project/Twine.m) is on Github! [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=example-buttongraph-3.png&userId=884330 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=communitypost-image-html.png&userId=884330 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=import-example-cpost.png&userId=884330 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=example-twine-import-3.png&userId=884330 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=example-twine-import-Ideal-3.png&userId=884330 Faizon Zaman 2018-07-11T18:22:42Z https://community.wolfram.com/groups/-/m/t/1384972 This project seeks to find the shortest distance between two coordinate locations on the surface of the Earth given a maximum possible slope, or threshold. I created a function called shortestDistance that takes four parameters: the first coordinate location (or city), the second coordinate location (or city), the slope threshold, and the image resolution. Using a module, I declared all of my local variables: shortestDistance[c1_, c2_, quality_, threshold_] := Module[{pos1, pos2, dist, bounds, br, center, geoRange, realPixelSize, data, terrainImage, gradient, d, m, rel, xn, yn, edges, graph, v, bin, del, pg, path, pix1, pix2, fullTerrain, mag, mesh, newPath, dropOne, testPath, scaledLength, actualLength, $size}, After that, I stored the coordinate points in {x, y} format of the two user-entered locations into the variables "pos1" and "pos2": pos1 = GeoPosition[c1]; pos2 = GeoPosition[c2]; The bounds of the image were adjusted to fit the entire area of interest. In this example, c1 represents Denver, CO and c2 represents Aspen, CO, and the adjusted terrain graph is shown below with the locations of the two cities and the midpoint between the cities. bounds = CoordinateBounds[{pos1[[1]], pos2[[1]]}]; br = Max[#2 - #1 & @@@ bounds]; center = Mean[{pos1[[1]], pos2[[1]]}]; geoRange = Transpose[{center - br, center + br}]; ![In this example, c1 represents Denver, CO and c2 represents Aspen, CO][1] and the elevation data was stored as a matrix in the variable "data." data = GeoElevationData[Transpose@geoRange]; I created four possible pixel dimensions for the size of the newly scaled image and assigned the value to the variable "$size" (eg. choice 2-> {200,200} would correspond to a 200 by 200 pixel resolution). The different resolutions were added to the menu because higher resolutions mean slower runtime: the user has the option to choose between speed and the quality of the image. $size = Replace[ quality, {1 -> {50, 50}, 2 -> {200, 200}, 3 -> {300, 300}, 4 -> {400, 400}}]; Next, I created a function "pixelSize" in order to determine the real distance of the path, in miles, given the distance of the path in pixels, and the definition of the function is shown below. Here, the function takes in two arguments: the range of the pixel values for the x and y coordinates as a single list "geoRange" and a "resolution" argument representing the pixel dimensions specified by the user, which was stored in $size in the previous step. pixelSize[geoRange_, {resolution_, _}] := Module[{x1, x2, y1, y2}, {{x1, x2}, {y1, y2}} = geoRange; GeoDistance[ GeoPosition[{x1, y1}], GeoPosition[{x2, y1}] ]/resolution ]; In the function call below, realPixelSize represents the ratio of $\frac{actual}{scaled}$ pixel lengths, and the original terrain image is rescaled to an image of the user-entered pixel dimensions realPixelSize = pixelSize[geoRange, $size]; terrainImage = ImageResize[Image[QuantityMagnitude[data]], $size]; The image below represents the resized terrain image, with lighter areas representing higher elevations while darker areas representing lower elevations: ![enter image description here][2] In one of the most important steps, the gradient filter is applied to the scaled terrain image: gradient = GradientFilter[terrainImage, 1]; Now for the gradient image...the image is lighter in areas with greater **slope** (unlike elevation of the terrain image) and darker in relatively flat terrain with little to no steepness. ![enter image description here][3] In the next block of code, each pixel on the gradient image is connected to the four adjacent pixels, and the duplicates are deleted using the DeleteDuplicates function since every two adjacent pixels (eg. pixel A and pixel B) will be connected twice (A->B and B->A) before the duplicates are deleted. d = #2 - #1 & @@@ geoRange; m = #1 & @@@ geoRange; rel = Round[Reverse[$size*(#[[1]] - m)/d] & /@ {pos1, pos2}]; {xn, yn} = ImageDimensions[gradient]; edges = DeleteDuplicatesBy[Flatten@Table[{ Pixel[i, j] \[UndirectedEdge] Pixel[i - 1, j], Pixel[i, j] \[UndirectedEdge] Pixel[i + 1, j], Pixel[i, j] \[UndirectedEdge] Pixel[i, j - 1], Pixel[i, j] \[UndirectedEdge] Pixel[i, j + 1] }, {i, 2, xn - 1}, {j, 2, yn - 1}], Sort]; graph = Graph[edges]; v = VertexList[graph]; Here is a visualization of the connected pixels after duplicates are deleted. ![enter image description here][4] The Binarize function is now applied to the gradient image, and all the pixel values greater than the user-inputted threshold will be replaced with a white pixel while all the pixel values less than the threshold will be replaced with a black pixel. The resulting binarized image is stored in the variable "bin." bin = Binarize[gradient, threshold]; ![enter image description here][5] All the white pixels (pixels with gradient above threshold) will be deleted using a separate function called FastVertexDelete, for which the definition and function call are down below: ---------- **Side Note:** *Why wasn't **VertexDelete**, a predefined function in Mathematica, used?* *VertexDelete took a long time to run, due to a possible bug in the function...to cut down runtime, a new function "FastVertexDelete" was created.* ---------- **Definition of FastVertexDelete:** FastVertexDelete[ graph_Graph, delete_List ] := With[ { dropQ = AssociationMap[ True &, delete ] }, Graph[ Complement[ VertexList @ graph, delete ], DeleteCases[ EdgeList @ graph, _[ _?dropQ, _ ] | _[ _, _?dropQ ] ] ] ]; FastVertexDelete[ graph_Graph, delete_ ] := FastVertexDelete[ graph, { delete } ]; **Function Call:** del = Pixel @@@ PixelValuePositions[bin, White]; {pix1, pix2} = Pixel @@@ rel; pg = FastVertexDelete[graph, Complement[Intersection[v, del], {pix1, pix2}]]; The Mathematica function FindShortestPath is now implemented to find the minimum distance path between the two user-entered coordinates:: path = Replace[FindShortestPath[pg, pix1, pix2], Except[_List] -> {}]; ![enter image description here][6] Now for a more in-depth analysis of the path finding mechanism... ## Visualization of FindShortestPath ## ---------- The connected "pixel plane" looks like this: ![enter image description here][7] If a pixel is deleted using VertexDelete, g = VertexDelete[graph, {Pixel[5, 5]}] the resulting pixel plane looks like this: ![enter image description here][8] When FindShortestPath is applied to two randomly chosen pixels on the plane, FindShortestPath[g, Pixel[5, 3], Pixel[5, 8]] the red dots show the shortest path. ![enter image description here][9] ---------- ---------- However, if there is no path, an error message is produced: If[path === {}, bin = bin; "Error: There is no path.", Otherwise, a function "dropOne" is implemented in order to minimize the length of the path even further: dropOne drops points on the path (excluding starting and ending points) that will still give a path disjoint from the white pixels that have been deleted. bin = ImageMultiply[bin, Erosion[ReplacePixelValue[ConstantImage[White, $size], List @@@ path -> Black], 1]]; fullTerrain = ImageAdjust@Image[QuantityMagnitude[data]]; mag = ImageDimensions[fullTerrain]/$size; mesh = ImageMesh[bin, Method -> "Exact", DataRange -> Transpose[{{1, 1}, ImageDimensions[bin]}]]; newPath = List @@@ path[[2 ;; -2]]; **Definition:** dropOne = Function[path, Replace[ SelectFirst[Range[2, Length[path] - 1], RegionDisjoint[mesh, Line[Delete[path, #]]] &], {d_Integer :> Delete[path, d], _ :> path} ]]; The new, improved path, achieved using the dropOne function, is named "testPath": testPath = FixedPoint[dropOne, newPath]; Notice how testPath improves the distance by "smoothening out" the path. ![enter image description here][10] The scaled length of the path (aka the path length in pixels) is now determined by using the EuclideanDistance. The scaled distance is converted to actual distance in miles by using the "realPixelSize" value computed at the beginning using the pixelSize function: scaledLength = N@Total[EuclideanDistance @@@ Partition[testPath, 2, 1]] (*with dropOne function*); actualLength = scaledLength*realPixelSize (*in miles*); **In this example with Denver and Aspen, the length of the path before dropOne was implemented was 128 miles while the length of the path after dropOne was implemented was 117.2 miles.** A grid is created to output a list of lists, specifically, a list of images: the raw graph representing the original path, the smoothened graph representing the improved graph after the dropOne function is implemented, the gradient graph showing the shortest path, and the full terrain image with relative elevations. Grid[{ {"Raw Graph: ", ImageResize[HighlightImage[bin, Line[List @@@ path]], 500]}, {"Smoothened Graph: ", ImageResize[HighlightImage[bin, Line[testPath]], 500]}, {"Gradient: ", ImageResize[ HighlightImage[ ImageAdjust@ GradientFilter[terrainImage, 1], {Line[{##} - 0.5 & @@@ testPath]}], 500]}, {"Terrain with path marked in red: ", HighlightImage[fullTerrain, {Line[mag*{##} & @@@ testPath]}]}, {"Distance: ", actualLength}}], Alignment -> Left ]] Further Work ------- A possible improvement that may be made is a quicker runtime: in fact, the image quality may be adjusted in my microsite in order to account for slow runtime. On the microsite, another problem is the need for the user to adjust the threshold in order to obtain the best possible graph: there should be a set numerical correlation between the actual gradient values and threshold since threshold is just a relative measurement of slope. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-15at11.27.45PM.png&userId=1372113 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-15at11.32.54PM.png&userId=1372113 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-15at11.37.32PM.png&userId=1372113 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-15at11.40.08PM.png&userId=1372113 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-16at8.49.25AM.png&userId=1372113 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-16at8.57.29AM.png&userId=1372113 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-15at11.40.08PM.png&userId=1372113 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-16at12.23.21PM.png&userId=1372113 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-16at12.28.15PM.png&userId=1372113 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-16at8.59.46AM.png&userId=1372113 Hee Jae Hong 2018-07-16T14:05:19Z https://community.wolfram.com/groups/-/m/t/1732283 ![A graph of the routes to various websites across the globe from near Boston.][1] ##Background## Routers connect computer networks together and send packets to the correct location. In computer networks, packets make multiple hops to different locations in order to reach their destination. The router determines how to send the packets based on the destination IP address. An IP address is an address that is assigned to each device connected to a computer network and allows for identification and communication. Public IP addresses have a geolocation associated with them that we can look up, although they are not always entirely accurate. A routing algorithm is used in order to determine the path that will be taken in order to reach a destination effectively based on a variety of factors such as distance and network traffic. Our project uses the ping time?—the round-trip time taken for a packet to go to and from your destination?— in order to determine the optimal route. ##Project Description## This project finds the route traveled by a packet as it makes its way to a given domain. The traceroute command was used in order to gather this data on various websites from across the globe. We could extract information about how long it took to receive a response from the servers as well as the IPv4 addresses of where our packets went. This data was then cleaned and formatted for use in visualizing a map of the results. Furthermore, a graph was created based off of these results with the nodes set to the unique locations visited by the packets and the edges weighted by the average ping time. Based off of these ping times, I found optimal routes to destinations. ##Functions## This function uses traceroute on a given domain and formats in into a list of associations. getRoute[domain_] := ( rawoutput = RunProcess[{"tracert", domain}];formatted = StringSplit[(StringSplit[rawoutput["StandardOutput"],"\r\n"][[4;;]] // StringTrim), " " |" "|" " |" " | " "][[;;-3]]; associations = Table[AssociationThread[{"index", "time1", "time2", "time3", "ip"} -> Table[formatted[[m, n]], {n, 1, 5}]], {m, 1, formatted//Length}]; regexIPPattern="((25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?))"; pingFormat = ___~~DigitCharacter~~___~~" ms"; Function[u,<|"Index"-> u["index"], "Time1"->If[StringContainsQ[u["time1"], pingFormat],Quantity[First@StringCases[u["time1"],DigitCharacter..], "Milliseconds"],Missing["NotAvailable"]], "Time2"->If[StringContainsQ[u["time2"], pingFormat],Quantity[First@StringCases[u["time2"],DigitCharacter..], "Milliseconds"],Missing["NotAvailable"]], "Time3"->If[StringContainsQ[u["time3"], pingFormat],Quantity[First@StringCases[ u["time3"],DigitCharacter..], "Milliseconds],Missing["NotAvailable"]], "IP" -> With[{match=StringCases[u["ip"],RegularExpression[regexIPPattern]->"$1"]},If[match==={},Missing["NotAvailable"], Entity["IPAddress",First[match]]] ] |>]/@associations) This function cleans the data of missing IP addresses and timed out responses. cleanResults[resultVar_]:=Cases[#,<|"Index"-> _,"Time1"-> _Quantity,"Time2"-> _Quantity,"Time3"-> _Quantity,"IP"-> _Entity|>]&/@resultVar This function extracts the location, in coordinates, and the average ping time, in milliseconds, from each hop in every route. If an IP address does not have a location associated with it, I don't use it in our data. GetLocationAndMeanTime[results_] := (Function[v, {First[v], v[[2]], Last[v]}] /@ DeleteCases[Function[u, {Mean[ToExpression /@ QuantityMagnitude[Take[u, 3]]], u[[4]][EntityProperty["IPAddress", "HostCoordinates"]], u[[4]]}] /@ Lookup[#, {"Time1", "Time2", "Time3", "IP"}], {_, _Missing, _}]) & /@ results The functions below plot assist in plotting the routes on a map. The colors of the routes depend on the relative ping times and I use the color schemes found in the Wolfram Language. GenerateElementGeoPaths[locationAndMeansElement_, colorFunction_] := Flatten[Function[v, Function[u, {{GeoMarker[u[[2, 2]], Graphics[Disk[]], "Scale" -> Scaled[0.015], "Color" -> colorFunction[u[[2, 1]]]]}, {Thickness[0.0008], colorFunction[u[[2, 1]]], GeoPath[{u[[1, 2]], u[[2, 2]]}, "Geodesic"]}}] /@ Partition[v, 2, 1]] /@ locationAndMeansElement, 1] GenerateGeoPaths[locationAndMeans_, colorScheme_] := Block[{ minmax, colorFunc }, minmax = MinMax[Flatten[locationAndMeans, 2][[All, 1]]]; colorFunc = ColorData[{colorScheme, minmax}]; Flatten[GenerateElementGeoPaths[#, colorFunc] & /@ locationAndMeans, 1] ] generateGraphs creates a graph where each unique location reached by traceroute is denoted by a node, and the edges are weighted by ping times. Coordinates are represented by the nearest city or area of population. generateGraphs[locationAndMeans_] := Block[{ locations, pingTimes, uniqueLocations, locationstoNum }, locations = (Flatten[locationAndMeans, 1])[[All, All, 2]]; pingTimes = Flatten@(Rest /@ (Flatten[locationAndMeans, 1])[[All, All, 1]]); uniqueLocations = DeleteDuplicates@(Flatten[(Flatten[locationAndMeans, 1])[[All, All, 2]], 1]); locationstoNum = Table[ First@Replace[locations[[m , n]], locations[[m , n]] -> First@Position[uniqueLocations, locations[[m , n]]]], {m, Length@locations}, {n, Length@locations[[m]]} ]; nearestCities = Table[GeoNearest[Entity["City"], GeoPosition[uniqueLocations[[i]]]], {i, uniqueLocations // Length}]; graphedRoutes = Graph[ Flatten[Table[Table[locationstoNum[[a, b]] -> locationstoNum[[a, b + 1]], {b, (locationstoNum[[a]] // Length) - 1}], {a, locationstoNum // Length}]], EdgeWeight -> pingTimes, VertexLabels -> Table[i -> Placed[nearestCities[[i]], Top], {i, uniqueLocations // Length}], VertexLabelStyle -> Directive[White, 9], VertexSize -> 0.2, EdgeStyle -> {Directive[Green, Arrowheads[.008]], (1 -> 1) -> Opacity[0.125]}, Background -> Black] ]; shortestPath returns the optimal locations a packet will go through in order to receive its destination. The input argument is a website link, which can be converted into an IP Address. After converting the IP address into coordinates, we then find the nearest city to it in the list of cities, nearestCities, that was developed in the generateGraphs function. shortestPath[website_] := Block[{ destination, nearestCity, f }, destination = GeoPosition[Entity["IPAddress", (First@First@HostLookup[website])]["HostCoordinates"]]; nearestCity = First@GeoNearest[Flatten@nearestCities, destination]; f[i_] := (nearestCities)[[i]]; Flatten@(f /@ FindShortestPath[graphedRoutes, 1, First@First@Position[Flatten@nearestCities, nearestCity]]) ] Collecting Data ------- The first step was gathering data. I found popular websites from around the world and performed traceroute on them in order to see how our packets will end up there and saved the results to a file. resultsA = getRoute /@ {"labanquepostale.fr", "lemonde.fr", "lefigaro.fr", "purepeople.com", "marca.com", "elmundo.es", "elpais.com", "milanucios.com", "pasion.com", "caixabank.es", "mercadolibre.com.mx", "caliente.mx", "animeflv.net", "unam.mx", "www.gob.mx", "commbank.com.au", "bom.gov.au", "seek.com.au", "woolworths.com.au", "carsales.com.au", "google.ca", "amazon.ca", "kijiji.ca", "cbc.ca", "desjardins.ca", "canada.ca", "youm7.com", "souq.com", "masrawy.com", "yallakora.com", "filgoal.com", "hkjc.com", "lihkg.com", "on.cc", "discuss.com.hk", "ulifestyle.com.hk", "baidu.com", "alibaba.com", "taobao.com", "qq.com", "bilibili.com" , "google.com", "youtube.com", "facebook.com", "amazon.com", "yahoo.com", "twitter.com", "ebay.com", "instagram.com", "wikipedia.org", "flipkart.com", "cricbuzz.com", "xbombo.com", "indiatimes.com", "news18.com", "flipkart.com", "cricbuzz.com", "xbombo.com", "indiatimes.com", "news18.com", "yad2.co.il", "zap.co.il", "bankhapoalim.co.il", "newsru.co.il", "sport5.co.il", "afip.gob.ar", "lanacion.com.ar", "bbva.com.ar", "bancogalicia.com.ar", "hollywoodbets.net", "tubidy.mobi", "mtn.co.za", "iol.co.za", "uol.com.br", "bet365.com", "americanas.com.br", "kooora.com", "www.men.gov.ma"}; resultsB = getRoute /@ { "hespress.com", "friend.com.kp", "ma.gov.kp", "airkoryo.com.kp", "nta.gov.kp", "ryongnamsan.edu.kp", "cooks.org.kp", "sdprk.org.kp", "gnu.rep.kp", "korfilm.com.kp", "yandex.ru", "ok.ru", "avito.ru", "gismeto.ru", "wildberries.ru", "drom.ru", "haraj.com.sa", "starzplay.com", "cimaclub.com", "moi.gov.sa", "souq.com", "vnexpress.net", "zing.vn", "24h.com.vn", "kenh14.vn", "shopee.vn", "baomoi.com", "ehawaii.gov", "webmasterserviceshawaii.com", "manoa.hawaii.edu", "alaska.gov", "adn.com", "uaf.edu", "alaskawildlife.org", "detik.com", "shopee.co.id", "bukalapak.com", "kompas.com", "sermitsiaq.ag", "banken.gl", "tusass.gl", "eltiempo.com", "computrabajo.com.co", "caracoltv.com", "canalrcn.com", "elcomercio.pe", "www.sunat.gob.pe", "mercadolibre.com.pe", "larepublica.pe", "www.viabcp.com", "ouedkniss.com"}; resultsC = getRoute /@ {"ency-education.com", "startimes.com", "elkhabar.com", "trademe.co.nz", "stuff.co.nz", "nzherald.co.nz", "ird.govt.nz", "bet9ja.com", "jumia.com.ng", "nairaland.com", "betradar.com", "ghanaweb.com", "lightdl.xyz", "ug.edu.gh", "nss.gov.gh", "yandex.uz", "mover.uz", "olx.uz", "gov.uz", "xcite.com", "talabat.com", "www.knetpay.com.kw", "moi.gov.kw", "daraz.pk", "watchonlinemovies.com.pk", "7starhd.work", "punjab.gov.pk", "ukr.net", "sinoptik.ua", "rozetka.com.ua", "prom.ua", "mit.edu", "harvard.edu", "princeton.edu", "stonybrook.edu", "columbia.edu", "stanford.edu", "umich.edu", "cmu.edu", "ut.edu", "utexas.edu", "risd.edu", "ua.edu", "wisc.edu", "washington.edu", "georgetown.edu", "uchicago.edu", "cornell.edu", "berkeley.edu", "vanderbilt.edu", "phoenix.edu", "illinois.edu", "mines.edu", "umass.edu", "reddit.com", "wolfram.com", "baidu.com", "bbc.co.uk", "ikea.com", "mail.ru", "yahoo.co.jp", "minecraft.net", "github.io"}; resultsD = getRoute /@ (RandomSample[("151.101." <> ToString[#] <> ".13" &) /@ Range[255], 20]); I saved these results to a file because the getRoute function can take time to run. Get[(*whatever file path you put your results in*)]; totalResults = cleanResults /@ (ToExpression /@ Drop[Names["results*"], 1]); locationAndMeans = GetLocationAndMeanTime /@ totalResults; Visualizing our Data ------- I generated a map with the locations plotted and connected to each other. GeoGraphics[{{GeoStyling["OutlineMap", Directive[Black, EdgeForm[Directive[{Thin, Opacity[0.75], Green}]]]], Polygon[{EntityClass["Country", "Countries"], Entity["AdministrativeDivision", {"Alaska", "UnitedStates"}], Entity["GeographicRegion", "Antarctica"], Entity["AdministrativeDivision", {"Hawaii", "UnitedStates"}]}]}, {GenerateGeoPaths[locationAndMeans, "NeonColors"]}}, GeoCenter -> Here, GeoZoomLevel -> 3, GeoBackground -> LinearGradientImage[{Black, Blue, Black}]] ![A graph of the routes to various websites across the globe from near Boston.][1] The greener colors represent faster ping times, while the red ping times are slower. I also generated a directed graph where locations of routers are represented by nodes. Graphs allow us to run shortest path algorithms and also allow for an interesting alternative visualization of the networks. generateGraphs[locationAndMeans] ![Graph of connections][2] ![examples][3] Here are some examples of the shortest route required to reach a domain from my current location. ##Limitations## There are many limitations with our results that prevent them from being fully accurate. For example, the coordinates associated with an IP Address does not always give us an accurate approximation of the host location. Also, on some hops, the nodes did not provide us with an IP Address, and consequently, they could not be used in our dataset. Additionally, in order to find the most efficient route, our algorithm relies on the current data I have already gathered, which raises the need for potentially crowdsourcing more data from the public. ##Future Work## Potential future results include the implementation of this project in different geolocations in order to gather information and see how packets travel from different parts of the world. This could be accomplished through crowdsourcing data from people of different parts of the world. I could also compare the optimal theoretical routes to the ones that exist in real life and examine the feasibility of implementing theoretical routes in order to design more efficient network systems. ##Acknowledgements## I would like to thank Christian Pasquel, my mentor, for guiding and assisting me in the development of this project. https://github.com/aaieiu/WSS-Template [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=nicemap.svg&userId=1724978 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=coolgraph.svg&userId=1724978 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=hi.png&userId=1724978 Alice Liu 2019-07-11T23:25:57Z https://community.wolfram.com/groups/-/m/t/1137401 Background ---------- The mathematics genealogy project is a website that collect data of mathematician and who is his/her adviser and student. Here one can trace their academic line all the way back to Newton's era. With an impressive number of entries (213588 people by July 5th 2017), I'm interested to take a closer look of their data to get an insight to mathematics community. The website can be accessed here: https://www.genealogy.math.ndsu.nodak.edu/index.php Data Scraping ------------- First step of the project is to get accessed to the data and turn it into Wolfram Language format. My approach is by downloading the html of each page and parse it to get information that we wanted. I chose not to do XML after noticing that there are some variations in the structure of each page. Each mathematician's page has a unique ID number that differentiate it from others, thus we can access all information just by changing the ID number: ![enter image description here][1] The function that I use to download each page is URLSubmit, which access the page in parallel instead of doing it sequentially. This means the functions make several request to the server and downloading the html code at once rather than accessing it one by one. It comes at the price of messing up with the order of the request (you can get ID 1, then jumping to ID 100 instead of doing it from 1-100 sequentially), but it's okay since we can order it later. receivedPages = {}; receiveHTML[html_, id_] := Module[{}, AppendTo[receivedPages, {html[[1]], id}] ] failHTML[html_, id_] := Module[{}, {"<p>You have specified an ID that does not exist in the database. \ Please back up and try again.</p>", id} ] startDownload[id_] := Module[{}, URLSubmit[ "https://www.genealogy.math.ndsu.nodak.edu/id.php?id=" <> ToString[id], HandlerFunctions -> <| "BodyReceived" -> (receiveHTML[#["Body"], id] &), "ConnectionFailed" -> failHTML|>, HandlerFunctionsKeys -> {"Body"}] ] Some caution is needed with the speed since if we make too much request at once it will crash and return an error instead. My approach is to put random pause every 5 pages (I tried to do every 10 pages before, but half of the time it gives me database error instead). Another thing to note is not to download all 200,000 pages at once. Good chances it will crash your kernel. Usually I like to to download about 10-20 thousand at once. Since it can take a while (around 20 minutes for 10,000 pages with random pause every 5), I like to use function `Monitor` to see my progress. receivedPages = {}; Monitor[ Table[ startDownload[i]; If[Divisible[i, 5], Pause[RandomReal[{0, 1}]]], {i, 1, 217304}], {i, ProgressIndicator[i, {1, 217304}]} ] // AbsoluteTiming All the downloaded html will go to the list `receivedPages`. Now we need to parse the html to get our data. The full description of the parser is long and tedious, so I won't put it here. You can see the full code in my notebook at the end of this post. Essentially, I'm mapping the function `stringParser` to `receivedPages` to get the data base. This will be fairly big, so we want to write it to separate file in case our kernel crashes. file = FileNameJoin[{NotebookDirectory[], "Final Database.m"}] stream = OpenAppend[file] listAssoc = Map[stringParser, receivedPages] writer[data_] := Module[ {i = Length[data], k = 1}, While[k <= i, WriteString[stream, InputForm[data[[k]]]]; WriteString[stream, ",\n"]; k++ ] ] writer[listAssoc] This will write the data that we have downloaded into Final Database.m (which will be created automatically). Now simply repeat the download process until we get all pages. After that, we can simply Import it to our kernel and put it as a dataset. Some important notes are: 1. The data is not properly ordered by ID. We want this to be ordered as it will make calling a certain ID much faster by taking the order it appears in dataset. 2. Some ID are not assigned to anyone. For example, by July 5th 2017, ID 206 is not assigned to anyone. By default the function I describe will give "No Mathematician has been assigned to this ID yet" in the "Name" column. Don't delete it for similar reason as note 1. Analyzing Data -------------- Now we get the data, it will have this structure: ![enter image description here][2] We can start playing around. The first thing that I do is to take a histogram of those that get their title between 1950-1990. listYear = finalData[All, "Personal Information", 1, "Year"] // Normal // ToExpression Histogram[Select[listYear, 1950 < # < 1990 &]] I get the following result ![enter image description here][3] This is quite interesting as it seems that there are certain point in history where there is a sudden increase of mathematician. Here it happens in 1962-1970, where the gradient took a drastic changes. To figure out what happens, we need to go back 5 years before, since on average it took 5 years to get a PhD. It turns out there is an important event that happens in 1957: Sputnik! During 1950s, the US government is preparing to launch an education initiative, but after Sputnik's launch in 1957 the program takes top priority realizing US is falling behind of Soviet in technology. So 1958 the US congress increased funding towards education. More info can be found here: [https://www.senate.gov/artandhistory/history/minute/Sputnik_Spurs_Passage_of_National_Defense_Education_Act.htm][4] There are other bumps, but I haven't got the chance to further research it. I would love it if anyone can help to explain the sudden stop in 1970s and a huge increase in late 1980s. Next is I want to found out the country distribution of our data. countryYear = finalData[All, "Personal Information", 1, {"Country", "Year"}] amountPerCountry[year_] := Module[{data, listCountry, howMany}, data = countryYear[Select[#Year == ToString[year] &]][All, "Country"]; listCountry = data // DeleteDuplicates // DeleteMissing; howMany[country_] := country -> Length[Select[data, # == country &]]; Map[howMany, listCountry] // Normal // Association // Dataset ] createChart[year_] := BarChart[amountPerCountry[year][[1 ;; 20]], ChartLabels -> Placed[Automatic, Automatic, Rotate[#, 90 Degree] &]] createMap[year_] := Module[{countryTally, countryEntities, toMap}, countryTally = amountPerCountry[year]; countryEntities = Interpreter["Country" | "AdministrativeDivision" ][ Keys[Normal[countryTally]]]; toMap = AssociationThread[countryEntities -> Values[Normal[countryTally]]]; GeoRegionValuePlot[toMap, ColorFunctionScaling -> False, ColorFunction -> (x \[Function] ColorData["DarkRainbow"][(x/270)^(1/4)])] ] Okay, let's test it on 2014 data ![enter image description here][5] It seems that our data is heavily biased towards American, as we can see America has a gigantic figure compared to everybody and Russia is shown to be the same level as Argentina/Norwegia. This doesn't seems to fit our experience where Russian plays a major part in the mathematics community. The bias probably is caused because it's not popular in Russia, so people doesn't submit their information. Some other observation is the fact that majority of Africa doesn't have any data. It can be either bias in database, or mathematics community really has not developed in Africa. Personally, I think it is more towards the later options, but I would love to hear opinions regarding this. One thing that I'm always curious is how the community develop. If we go back to history, often mathematics idea come from a certain country, then spread around to other country, which then the new country will develop their own mathematics idea. A good example is how Algebra spread Middle East to Italy by Fibonacci, which then sparks more works about the subject leading to the solution of 3rd degree polynomial. Using the database, I'm trying to see the progression of knowledge between country by identifying mathematician who has an adviser from different country. Since the code is somewhat long, I'll just post the result, and the source code can be seen in the notebook. Here is the percentage of mathematician with foreign adviser among everyone in the database: ![enter image description here][6] Surprisingly high number of mathematician has a foreign adviser! It seems mathematics is an international business. Still, this result might be biased since the majority of our data come from 20th Century USA. Trying the same approach towards those in 19th century, we get more conservative result: ![enter image description here][7] Only 8% of mathematician is confirmed to have foreign adviser in 19th century. It is still possible for this number to grow since there are 40% missing data. Still, it shows how the advent of technology makes it easier for ideas to spread. Of course, there are various things to be explored in this direction, but because of time constraint this is the result that I get so far. I would love to hear more ideas how to explore this. My last work is to create a genealogy tree of someone's adviser(s). Here is the code used: getAdvisor[id_Integer] := Module[{advisor = finalData[id]["Personal Information", All, "Advisor"] // Normal // Flatten}, ToExpression@DeleteMissing[advisor] ] goBack[id_] := Map[id -> # &, getAdvisor[id]] createTree[id_, generation_] := Module[{list, i, assoc}, list = {{id}}; i = 1; While[i <= generation, list = Join[list, {Map[getAdvisor, (list[[i]] // Flatten )] } ]; i++ ]; assoc = Map[goBack, list // Flatten // DeleteDuplicates] // Flatten; Graph[assoc, VertexLabels -> Map[# -> Last@StringSplit[finalData[#, "Name"]] &, DeleteDuplicates[Join[Part[assoc, All, 1], Part[assoc, All, 2]]] ] ] ] Out of respect of Wolfram language, here is the genealogy of Stephen Wolfram up to 10 generations ![enter image description here][8] And that concludes my current result of exploration. For future directions, I have a list of ideas that I would like to try: 1. Model how mathematics community develop 2. Explore trend of subject by country and year 3. Correlation between advisor's and student's dissertation topic 4. Analysis of MathSci Net 5. Use Machine Learning to identify person' s heritage from his/her name, then use it to analyze how it affects the person descendants If you have any suggestion/comments, I would love to hear it. Hope you guys enjoy the post! [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=URLPicture.png&userId=1136056 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot%2821%29.png&userId=1136056 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Histogram1950-1990.gif&userId=1136056 [4]: https://www.senate.gov/artandhistory/history/minute/Sputnik_Spurs_Passage_of_National_Defense_Education_Act.htm [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=MapHistogram2014.png&userId=1136056 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=PieChartAll.png&userId=1136056 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=PieChart19thCentury.png&userId=1136056 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=WolframGenealogy.png&userId=1136056 Ricky Simanjuntak 2017-07-05T22:05:04Z https://community.wolfram.com/groups/-/m/t/1383617 ![A map of the world in 1700][2] **Utilizing the Brélaz Heuristic to Produce Efficient Four-Colorings of Historical Geopolitical Maps** The goal of this project was to develop a system that provides a four-coloring of historical geopolitical maps, utilizing minimum cycle completion algorithms and the Brelaz coloring heuristic. The intention here was mostly as an intellectual exercise - the functional paradigm of the Wolfram language lends itself quite nicely to implementing a four-coloring of a map, and the magnitude of data available from the Wolfram Knowledge Base allowed a very nice application of this mathematical theorem to a real-world example, and I thought it would be interesting to combine the two in an application. #Beginnings Wolfram has a very nice collection of the polygons of historical countries in its data repository. This data was used to develop the maps of the historical countries. Unfortunately, however, the entities in "HistoricalCountries" don't have a "BorderingCountries" property. This was a little bit troublesome, as it was necessary to know the bordering countries in order to color the map. A BorderingCountries function was written to remediate this. getRegion[polygon_] := DiscretizeGraphics@ Cases[polygon, Line[a___], Infinity] BorderingCountries[countries_, country_, c1_, year_] := Module[{pts, r}, pts = Identity @@@ MeshPrimitives[getRegion[Dated[country, year]["Polygon"]], 0]; r = Table[Min[RegionDistance[i, pts]], {i, c1}]; Pick[countries, Thread[r < 0.03]] ] This function retrieved every country within a latitude/longitude range of 0.03° that had a polygon for the given input year. This will be used later in the map generation function. #First Attempts at Coloring I began by declaring variables and methods for ensuring all of the countries were properly called and mapped onto Wolfram's default world spread: yearWorldMap[i_] := toColor[tf_] := <|{False, False} -> Red, {False, True} -> Blue, {True, False} -> Green, {True, True} -> Yellow|>[tf] Module[{}, year = DateObject[List[i], "Year", "Gregorian", -4.`]; inrange = Keys@Select[CloudImport@CloudObject["HistoricalCountries.wxf"], yearWithinQ[year, #] &]; countries = Pick[inrange, Not@*MissingQ /@ EntityValue[Dated[inrange, year], "Polygon"]]; c1 = getRegion /@ (EntityValue[Dated[countries, year], "Polygon"]); countryneighbors = {#, DeleteCases[BorderingCountries[countries, #, c1, year] , #] } & /@ countries; countrybooleans = # -> {x[#], y[#]} & /@ countries; Then, the first attempt at a minimum vertex cycle algorithm was implemented (and also put into the yearWorldMap module). eqs = And @@ (Flatten[ Function[{c, n}, BooleanConvert[Xor[x[c], x[#]] || Xor[y[c], y[#]], "CNF"] & /@ n] @@@ countryneighbors]); solution = Join[Replace[ FindInstance[eqs, Union[Cases[eqs, _x | _y, \[Infinity]]], Booleans], {{first_, ___} :> first, _ :> {}}], Flatten[{x[#] -> True, y[#] -> True} & /@ Flatten[Cases[countryneighbors, {_, {}}]]]]; coloring = Quiet[(Dated[#[[1, 1, 1]], year] -> Lighter@Lighter@toColor[Last /@ #]) & /@ Partition[SortBy[solution, #[[1, 1]] &], 2]]; For early history (1000 BC to 100 BC), this algorithm was reasonably fast. However, many issues emerged during testing: 1. The threshold `r` used for the `BorderingCountries` function was a little bit strange to work with. Initially, if the `r` value was hard to obtain with the cycling algorithm, because the algorithm would fail if the `r` provided was too big and returned any overlapping country polygons. However, after much experimentation, I was able to get a satisfactory `r` value. 2. The development process under this algorithm was very tedious. There were many variables to keep track of, and many things broke very often. For instance, whenever there was a country overlap and the computer couldn't distinguish between polygons, it often defaulted to the `(True, True)` condition, leaving most of the map blank and only using the color yellow when the condition applied.![enter image description here][4] 3. Perhaps the most glaring issue was that the minimum cycle algorithm became extremely slow for more recent years. This is because more countries existed as time moved forward, and thus, the algorithm takes much longer to color the map (the minimum cycle vertex algorithm completes in exponential runtime). #Using the Brélaz heuristic After much testing, I finally decided that I needed to remove the minimum vertex cycling algorithm, as it was simply too computationally expensive and inefficient to implement at the scale I desired for this project. Of course, that meant figuring out another algorithm to use. Prior to Version 11 of *Mathematica*, a graph theory package called *Combinatorica* had a simple function called `BrelazColoring` that would color a graph according to the Brélaz heuristic¹, which provides good, but not necessarily minimal colorings for a graph. As the goal for this project was to four-color a map, using the Brélaz heuristic as the basis for the coloring method was a good idea because a minimal coloring wasn't *absolutely* necessary the map was a good idea. To use `BrelazColoring`, I first needed to convert my world map into a graph, color the vertices of the graph, and then apply the coloring to the map. The code I used to do so was Quiet[<< Combinatorica`] rules = Thread[# -> Range[Length[#]]] &@ Union[Flatten[countryneighbors]]; edges = List /@ Join @@ Thread /@ countryneighbors /. rules; vp = List /@ RandomReal[{0, 1}, {Length[rules], 2}]; colors = BrelazColoring[Graph[edges, vp]]; polys = EntityValue[Thread[Dated[rules[[All, 1]], year]], "Polygon"]; This worked very well, and was able to produce accurate four-colorings of historical maps, #Making the Microsite What is a good function without a nice place for other people to use? As mentioned in the introduction of this post, a major portion of this project was the real-world applicability of the map function. To allow others to use it, I decided to create a microsite hosted on the Wolfram Cloud. I wanted a little bit more than a simple `FormPage`, so I added a little bit of styling to the website: CloudDeploy[ FormPage[{"Year" -> <| "Interpreter" -> Restricted["Integer", {-1000, 2018}], "Help" -> "Use a hyphen (-) for BC years.", "Hint" -> "Enter a year"|>}, Once[yearWorldMap[#Year], "Cloud"] &, AppearanceRules -> <|"Title" -> "<b>Maps</b> Throuhgout History", "Description" -> "</style>Enter a number to see the geopolitical map for that \ year. After, click below to see a video of the map changing over \ time.", "SubmitLabel" -> "Give me the map!", "PageTheme" -> "Blue"|>], "Maps", Permissions -> "Public"] You can access the microsite [here](https://www.wolframcloud.com/objects/nikeshmishra01/Maps). #Future Work As of right now, the function that generates a map only works for years ranging from 1000 BC to 1950 AD. This is because, after much experimentation, I failed to find a way to incorporate the polygon's of modern countries into my code without destroying the modern map. I do intend to find a solution to this, and extend the AD range of the mapping function to 2018 (or whatever the current year, assuming I have enough cloud credits to sustain it into the future.) ---------- ¹As a side note, the reason Brélaz got a "heuristic" and not an "algorithm" named after him is because graph coloring is computationally hard and is an NP-complete problem. In general, NP-complete problems cannot be solved by algorithms in a reasonable amount of time (they need exponentially more time to solve); however, because the Brélaz heuristic often gives such good results, it is often referred to as an algorithm; even [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=map.jpg&userId=1371691 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=GoodMap.png&userId=1371691 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Overlapmap.png&userId=1371691 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Yellowmap.png&userId=1371691 Nikesh Mishra 2018-07-14T04:26:14Z https://community.wolfram.com/groups/-/m/t/1728662 ![Aggregation System of a Totalistic Rule][1] **Aggregation System of a Totalistic Rule** ![enter image description here][2] **All possible paths the Aggregation System can take** ##Introduction ## Aggregation Systems are a stochastic analog to the Cellular Automaton. Unlike Cellular Automaton, where every step is deterministic and it grows one row at a time, Aggregation Systems grow by adding one cell at a time at randomly chosen locations. But at the same time, there are certain underlying rules similar to the Cellular Automaton rules they follow. So, it is random but has a deterministic tinge of the Cellular Automata rules. For example, one step of Rule 30 in CA and AS, ![enter image description here][3] *Rule 30 CA* ![enter image description here][4] *Rule 30 AS* As you can see, the Aggregation System model basically follows the rules of the Cellular Automaton but instead of adding all the cells in the following row, it picks one at random. After around 30 steps, this is how they both look (Rule 30 of elementary Cellular Automaton). ![enter image description here][5] ***CA*** ![enter image description here][6] ***AS*** A lot of "random" behavior of nature could be modeled using the Outer Totalistic and Totalistic Rule Set of the Aggregation System and hence, most of the results in the following post are calculated for the Outer Totalistic Case (2D) with an initial condition of an array with one black cell at the center. ## Aggregation System Function ## Clear[framedAggregationSystem]; framedAggregationSystem[rule_, init_, steps_]:= Catch[Module[{r, p, pos, output1},Nest[ ( r=CellularAutomaton[rule,#]; pos= Position[r, Except[0], {Depth[init]-1}, Heads->False]; If[pos=== {}, Throw[#]]; p=RandomChoice@pos; output1 = ReplacePart[#,p-> Extract[r, p]] )&,init,steps]]] *Running this code for Outer Totalistic Rule # 30, gives an image something like this:* ![enter image description here][7] ## Efficient implementation of the same ## But this algorithm is inefficient because one needs to define an arbitrary size of the frame to fit the Aggregation System and the algorithm goes on evaluating the white background cells even when the Aggregation System dies down. The next step was to overcome this issue. For that, I evaluated each step of the Aggregation System and evolved the frame accordingly along with the frame. So I pad the initial condition, evaluate the rule and blacken the cell, and then unpad if needed. Here's the code for that: unpad[a_]:=(ReplacePart[a,Thread[(Replace[#,All->_,1]&/@Select[Catenate@Table[Append[ConstantArray[All,n],m],{n,0,Depth[a]-2},{m,{1,-1}}],AllTrue[Flatten[Extract[a,#]],#===0&]&])->Nothing]]) Clear[AggregationSystem]; AggregationSystem[rule_, init_, steps_]:= Catch[Module[{r, p, pos, output1,output2,cent=0},Nest[ (output1=ArrayPad[#,1]; cent+=1; r=CellularAutomaton[rule,output1]; pos= Position[r, Except[0], {Depth[init]-1}, Heads->False]; If[pos=== {}, Throw[#]]; p=RandomChoice@pos; output1 =output2= ReplacePart[output1,p-> Extract[r, p]]; output1=unpad[output1]; output1 )&,init,steps]]] ArrayPlot@AggregationSystem[<| "OuterTotalisticCode"-> 30 , "Dimension"-> 2|>, CenterArray[1, {1,1}], 200] *Running rule 30 with this:* ![enter image description here][8] This makes it highly efficient: ![enter image description here][9] *TIme vs iterations of both the algorithms* ## Overview of the rules ## The space of outer totalistic rules is about 262143. But odd rules are uninteresting as they flicker and some rules simply do not grow given the initial condition of the Center Array. Eliminating them, I was left with 65536 rules which are still large. One of the brute force ways to get some intuition and understanding about which directions to look for is to simply run all the rules and stare at them: ![enter image description here][10] **First 100 Outer Totalistic Rules for about 200 iterations** ## **TESTS AND EXPERIMENTS** ## ## Dimensions## If one stares at the rules for a while, you realize that there is some sort of burst in the dimensions after a certain discrete rule number. This hints towards behavior during systems where there is a phase change of some sort. For example, rule 510 ->516: ![enter image description here][11] This happens all the time and is not by chance. Iterating each rule 20 times and plotting the dimensions: ![enter image description here][12] *X and Y coordinates of rules 510 and 516 when run multiple times.* In other words, this is the result of the tinge of determinism in the rules of the Cellular Automaton applied to "random" Aggregation Systems. Plotting the dimensions for the whole rule space of Outer Totalistic: ![enter image description here][13] The spikes mainly occur around the powers of 2 because that is where the rules undergo a major change in terms of the number of cells turning to black given a neighborhood. ## Standard Deviation ## On iterating each rule a several number of times, I got a different picture almost every time as the cells are picked one at a time from a set of finite possible options. This raises the question of whether there exists some sort of a behavioral characteristic to a rule we can predict beforehand given the rule number. One of the measures to look at it is the Standard Deviation of the pixel values {0,1} after iterating a rule for a fixed number of iterations. So given, the number of iterations for each rule and the number of rules we want this result for, here's the function that gives the standard deviation of the cell values: available = Select[Range[2^18-1],EvenQ[#] &&!IntegerQ[#/8]&&!IntegerQ[(#-10)/8]&]; stdeviationrandomavailable[iterations_, n_]:= ( a = RandomSample[available, n]; KeyValueMap[N@StandardDeviation@#2&,Merge[Table[AssociationMap[AggregationSystem[<| "OuterTotalisticCode"-> # , "Dimension"-> 2|>, CenterArray[1, {50,50}], 500]&, a], {k,iterations}],Identity]] ) AssociationThread[a, ArrayPlot/@stdeviationrandomavailable[10, 5]] **Output:** ![enter image description here][14] Doing the same for a higher iteration value: ![enter image description here][15] I noticed that many of the rules have a dark halo at the edges. This happens because when we run a rule a multiple number of times, the inner section almost remains the same; like a dense blob. Only at the outer parts of the system that there is an uncertainty of the positions of the cells leading to a higher standard deviation. But this is not always true as one would normally expect. For example, **Rule 2143:** ![enter image description here][16] In this case, there is uncertainty engraved in the rule from the very beginning and the standard deviation plot almost looks like a black blob. If we go on to plot something analogous to the moment of inertia in that case of these Standard deviation visuals (vs Rule Number), we get an idea as to what is the distribution of the two types of Standard Deviation representations. datastdev = Import["stdeviationdata.mx"]; ListPlot@AssociationThread[labels, Table[N[Total[Flatten@MapIndexed[#1*(EuclideanDistance[Dimensions[datastdev[[n]]]/2,#2]^2)&,datastdev[[n]],{2}]]], {n, 1, 3000}]] ![enter image description here][17] Histogram: Histogram[AssociationThread[labels, Table[N[Total[Flatten@MapIndexed[#1*(EuclideanDistance[Dimensions[datastdev[[n]]]/2,#2]^2)&,datastdev[[n]],{2}]]], {n, 1, 3000}]]] ![enter image description here][18] On looking for the distribution, FindDistribution[Table[N[Total[Flatten@MapIndexed[#1*(EuclideanDistance[Dimensions[datastdev[[n]]]/2,#2]^2)&,datastdev[[n]],{2}]]], {n, 1, 3000}]] we get the following: MixtureDistribution[{0.9262480618395671`, 0.07375193816043307`}, {LogNormalDistribution[10.709938521692017`, 0.24927531644683798`], LogNormalDistribution[11.375808011619768`, 0.3116990014250025`]}] ## Mean ## Another thing that comes to mind after Standard deviation is the mean of the rules after iterating multiple times. Similar to the standard deviation, here's the code for the mean calculations: meanrandomavailable[n_, iterations_]:= (a = RandomSample[available, n]; KeyValueMap[ArrayPlot[N@Mean@#2, PlotLabel-> #1]&,Merge[Table[AssociationMap[AggregationSystem[<| "OuterTotalisticCode"-> # , "Dimension"-> 2|>, CenterArray[1, {45,45}], 200]&,a], {k,iterations}],Identity]]) meanrandomavailable[10,10] ![enter image description here][19] This again tells us about the characteristic of rules. Certain rules like 159454 have a Gaussian distribution implying that they're more likely to land in that particular spot than in other places. On the other hand, some rules like 193062 are by and large of the same probability everywhere implying that a cell is equally likely to land in any given area. They display a dispersed behavior in comparison to the rules like 159454. ## **Confluence** ## Confluence is essentially a property of a rewrite system which indicates whether or not a system (observed) can be transformed or rewritten in a way that the input of an abstract rewrite pair overlaps to the same result after the following iteration. If this happens over a single rewrite rule iteration for all given states of a system, the system is said to be locally or weakly confluent and the system is said to display the Church-Rosser property. If this, occurs over multiple transformation steps, the system is said to be globally confluent. Confluence is usually studied in deterministic systems and the study of confluence hasn't really been taken up in stochastic systems. Here, I aim to bring up an idea of confluence in the case of these stochastic Aggregation Systems. ## "Theoretical" evaluation of Confluence Levels ## Given an initial condition of the Center Array and a rule, there are different states in which a system can evolve to. Some of these states can be further evolved to converge into the same state. For example, ![enter image description here][20] Code for the above: Clear[DeterministicAggregationSystem]; DeterministicAggregationSystem[rule_, init_]:= Catch[Module[{r, pos},Nest[ ( r=CellularAutomaton[rule,#]; pos= Position[r, Except[0], {Depth[init]-1}, Heads->False]; If[pos=== {}, Throw[#]]; Function[p,ReplacePart[#,p-> Extract[r, p]]]/@pos )&,init,1]] ] The above fuction lists all the possible states from one iteration to the other. removeSelfLoops[g_Graph]:=Graph[DeleteCases[EdgeList[g],(DirectedEdge|UndirectedEdge)[x_,y_]/;x===y],Sequence@@Options[g]] theoreticalconfluencegraph2[rule_,iters_,initI_:CenterArray[1,{5,5}]]:=Module[{graphint}, graphint = Graph[Labeled[#,#,Center]&/@VertexList[#],DeleteDuplicates@EdgeList[#]]&@Graph[ Catenate[Module[{newInit},Reap[Nest[ Catenate@*Map[Function[init, newInit=DeterministicAggregationSystem[rule,init]; Sow[ArrayPlot[init,ImageSize->15]\[DirectedEdge]ArrayPlot[#,ImageSize->15]&/@newInit]; newInit ]], {initI},iters]; ]][[2,1]]] ]; removeSelfLoops[graphint] ] g = theoreticalconfluencegraph2[<| "OuterTotalisticCode"->30, "Dimension"-> 2 |>, 2]; g = HighlightGraph[g, {ReplacePart[VertexList[g][[{1,2}]],0->DirectedEdge]}]; g = HighlightGraph[g, {ReplacePart[VertexList[g][[{2,14}]],0->DirectedEdge]}]; g = HighlightGraph[g, {ReplacePart[VertexList[g][[{1,3}]],0->DirectedEdge]}]; g = HighlightGraph[g, {ReplacePart[VertexList[g][[{3, 14}]],0->DirectedEdge]}] The highlighted part of the graph is one of the possible paths that can be taken by the system that converge after two iterations. We calculate the probability of achieving such states since these bring the confluence to the rule. For example, there is a {1/80, 1/80 } chance to take those paths on multiple iterations. Then, we go on to calculate such probabilities for all such convergent states and take the sum. This, in essence, defines a theoretical confluence level of a particular rule. theoreticalconfluencevalue [graph_]:= (Module[{val, probs},probs = Select[AssociationMap[Apply[Function[{v1,v2},Function[path,1/Times@@(VertexOutDegree[graph,#]&/@Most[path])]/@FindEdgeIndependentPaths[graph,v1,v2,Infinity]]],Permutations[VertexList[graph],{2}]],Length[#]>1&]; Print[probs]; val = N[Total@Flatten@Values@probs] ]) theoreticalconfluencevalue[g] ![enter image description here][21] **Output confluence value: 0.641667** ## Experimental Evaluation of weak confluence ## Until now, we algorithmically defined and calculated the theoretical confluence level of a given ruleset. But the speculation is that this might not be so simple after all and it is a good idea to compare it to the real Aggregation System by actually running it and fetching raw data. ## Algorithm and evaluation ## Given a rule set and the initial condition of the central array, two iterations of the Aggregation Systems are evaluated for a certain sample number of times (200+) and displayed as a graph. To get the confluence level in the ruleset, we first count the number of pairs of edges that point to a particular state in the second iteration from non-overlapping first iterations. We then divide this number by the total number of "VertexOut" edges from the corresponding first iteration states. Finally, if this occurs for multiple states in the second iteration, the ratios are independently added and the resulting value is the experimental confluence level of the ruleset. confluencegraph[rule_, iter_]:=(Module[{step1, step2, g, confgraph}, step1=Table[AggregationSystem[<| "OuterTotalisticCode"-> rule, "Dimension"-> 2 |>,CenterArray[1, {10, 10}], 1], {i, iter}]; step2 = Table[AggregationSystem[<| "OuterTotalisticCode"-> rule, "Dimension"-> 2 |>,step1[[i]], 1], {i, iter}]; g=Graph[Flatten[{ Thread[DirectedEdge[(ArrayPlot[#,ImageSize->20]&/@step1),(ArrayPlot[#,ImageSize->20]&/@step2)]] }]]; confgraph = removeSelfLoops@Graph[Labeled[#,#,Center]&/@VertexList[g],EdgeList[g]] ]) ![enter image description here][22] confluencevalue[graph_Graph]:=Module[{keys, inOutDegree, exprob}, (keys=Keys@countofpairs[graph]; inOutDegree=AssociationMap[AssociationMap[VertexOutDegree[graph,#]&,DeleteCases[VertexInComponent[graph,#,1],#]]&,keys]; exprob=Merge[{countofpairs[graph],Total/@inOutDegree},#[[1]]/#[[2]]&]; Total[exprob])] experimentalconfluencegraph = confluencegraph[100, 100] confluencevalue[experimentalconfluencegraph]//N **Output Confluence Value: 1.24847** ## Conclusion ## A function was successfully fabricated to give out the Aggregation System given the rule number, initial conditions, and the number of iterations (exactly like Cellular Automaton). Following that, the function was made efficient by precisely fitting it to the frame. Then, certain properties like dimensions, standard deviation, and mean were studied which revealed some behavioral patterns which hint towards natural events like phase changes in a system. Finally, the study of confluence, which is usually done on a deterministic system, was undertaken giving statistics on the "confluenciality" of a stochastic model of this type. ## Future Work ## 1. Extending the function to include 3D Aggregation Systems. 2. Extending similar studies to a general space of initial conditions and other rule sets. 3. Looking for interesting patterns by analyzing parameters like fractal box dimension, growth of the system with time, etc. 4. Continue investigations on confluence in the rule space and look for stronger results. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Agg_System.jpg&userId=1726294 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=raphhighlighted.jpg&userId=1726294 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img3.jpg&userId=1726294 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img4.jpg&userId=1726294 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img5.jpg&userId=1726294 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img6.jpg&userId=1726294 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img7.jpg&userId=1726294 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img8.jpg&userId=1726294 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img9.jpg&userId=1726294 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=totalisticrules.gif&userId=1726294 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img10.jpg&userId=1726294 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img11.jpg&userId=1726294 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img112.jpg&userId=1726294 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img13.jpg&userId=1726294 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img14.jpg&userId=1726294 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img15.jpg&userId=1726294 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img16.jpg&userId=1726294 [18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img44.jpg&userId=1726294 [19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=cmbig.jpg&userId=1726294 [20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=raphhighlighted.jpg&userId=1726294 [21]: https://community.wolfram.com//c/portal/getImageAttachment?filename=k.jpg&userId=1726294 [22]: https://community.wolfram.com//c/portal/getImageAttachment?filename=expp.jpg&userId=1726294 Kabir Khanna 2019-07-10T17:15:56Z https://community.wolfram.com/groups/-/m/t/1382967 I was assigned by Stephen Wolfram to create a sorting a network that could sort a specific list. To do this, I started by analyzing the optimal sorting network for a list of 16 items, which is in fact, the largest solution that humanity has found so far. ![This is 16][1] in the image above, there are two boxes, I noticed the pattern in the smallest of the two first, which in every optimal sort I checked, was used off the bat to group up sets of 4. ![this is 7][2] Next, by analyzing 14,15 and 16, 14, and 15 shown below. ![enter image description here][3] I derived a pattern for what was happening in the larger boxes, namely, there are beams of length 2^n or of the form {1+c,2^n+c} where c mod(2^(n+1)) <2^n. After this, I was prompted to create an algorithm that could automatically create a list of list of pairs that specified these connections. Essentially, I was looking for something of the form {{1,2},{3,4},{5,6},{7,8},{1,3},{2,4},{5,7},{6,8},{1,5},{2,6},{3,7},{4,8}}. The code to do this was complicated, though through perseverance I successfully did it. The code is shown below: function1[distanceBetweenEle_, list_, finalList_] := (Module[{arc, apair, apairamid, pairs}, Partition[list, distanceBetweenEle, distanceBetweenEle]; apair = Part[Partition[list, distanceBetweenEle, distanceBetweenEle], Span[1, -1, 2]]; Map[{#, # + distanceBetweenEle} &, Flatten[apair]]; apairamid = Map[ Function[ {itemInList}, {itemInList, itemInList + distanceBetweenEle} ], Flatten[apair] ]; pairs = Select[ apairamid, Function[ {item}, Not[Part[item, 2] > Length@list] ] ]; arc = Join[finalList, pairs]; If [(Length[list] + 1 > distanceBetweenEle*2), function1[distanceBetweenEle*2, list, arc], Return[arc]; ]]) This was a great start. Though we now had to figure out what to do for the second half of the list. So let us take a look at the ends of the optimal algorithm for 14th 15 and 16 elements. ![This is the ends of 14-16][4] The first thing that most people should notice is that the connections follow no clear pattern. Despite this, there is one portion we will be able to exploit. If you look at the images above, you will notice that all new connections originated from the new segments. We can exploit this and proceed to only check connections from the old segment. The code for how I did this is below. ClearAll[thingsToCheck] thingsToCheck[L_, list_List, nope_] := Insert[list, {L, nope}, {#}] & /@ Prepend[(First /@ Position[list, L | 1] + 1), 1] ClearAll[mainFunction] mainFunction[L_, list_List] := Select[Flatten[thingsToCheck[#, list, L] & /@ Range[1, L - 1], 1] // DeleteDuplicates, Length[#] === Length[Split[#]] &] Finally, I needed to implement a checker to check if the list could be sorted. No exploits were used for this segment, though in the future, presorting the first half could simplify the checker and would allow for greater number of checked permutations. The code is shown below. ClearAll[swap] swap[list_, {n_, m_}] := If[list[[n]] > list[[m]], ReplacePart[ list, {n -> Part[list, m], m -> Part[list, n]} ], list ] ClearAll[allSwapInstructions] allSwapInstructions[swapInstruc_, id_] := Fold[swap, id, swapInstruc] ClearAll[checker] checker[swapInstruc_, L_, id_] := Range[L] === allSwapInstructions[swapInstruc, id] Finally, we devised a final code snippet that connected all previous codes segments together: ClearAll[theOnesThatWork] theOnesThatWork[list_List, len_, id_, firstHalf_] := SelectFirst[Join[firstHalf, #] & /@ list, checker[#, len, id] &] And we were done. Some testing is shown below: id = {5, 2, 4, 1, 3}; step1 = mainFunction[5, {{2, 3}}] theOnesThatWork[step1, 5, id, function1[1, Range@5, {}]] step2 = Flatten[mainFunction[5, #] & /@ step1, 1]; theOnesThatWork[step2, 5, Reverse[Range[5]], function1[1, Range@5, {}]] Special thanks to http://demonstrations.wolfram.com/SortingNetworks/ [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ihasuhthzzzz.png&userId=1372143 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=7.png&userId=1372143 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=14and15.png&userId=1372143 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Endsof456.png&userId=1372143 Sasha Kucher 2018-07-13T19:59:16Z https://community.wolfram.com/groups/-/m/t/1728556 ![enter image description here][1] **Introduction** ------------ A Petri net includes places, transitions and arcs. Arcs must go from a place to a transition or vice versa, which makes a Petri net a directed bipartite graph and the nodes represent transitions (events that may occur to cause change in states, marked by square) and places (conditions, marked by circles). These conditions make our first group of functions to check if the input structure is a Petri net, with the function named petriNetQ. Petri net is very useful because it is inherently graphical, good at representing concurrency and some interesting properties of nets can be expressed in terms of reachability. Hope more can be added to make the Petri net package more powerful. **Visualization and Animation** ------------------------------- Here we have a package to make a Petri net and visualize it. ClearAll[petriNetRun]; petriNetRun[pnet_, init_, step_Integer]:= Module[ {current = init, g, index}, current = Nest[updateFiring[pnet], current, step-1]; index = First @ RandomChoice[Position[checkFiring[pnet, #, current] &/@ pnet[[3]], True]]; If[IntegerQ[index], makeFiring[pnet, pnet[[3,index]], current], Print["Dead!"]; Abort[]]; g = petriNetInit[pnet, current]; HighlightGraph[g, {pnet[[3,index]]}] ] We then tried to visualize the movement of the Petri net in 15 steps. ![enter image description here][2] Also for convenience, we have three different user interface to generate Petri net given Petri net data structure, chemical reactions and system of transitions. ![enter image description here][3] ![enter image description here][4] If a user gives the correct input, he or she will receive an animation of the Petri net similar to the one we display. **Petri net properties** ------------------------------- Petri net, as a mathematical modeling language, indeed is not limited to visualize chemical processes. In fact, any mathematics model can be somewhat expressed with Petri net. However, from Wikipedia, papers written by John Baez, and StateBox archive, here are some open questions discussed with Petri net. The first problem is Reachability. According to Wikipedia, The reachability problem for Petri nets is to decide, given a Petri net N and a marking M, whether M can be reached from current state. This problem actually is not easy, and it was shown to be EXPSPACE-hard. But these days it turned out to be elementary. Here is a function named petriNetReachableQ. petriNetReachableQ [ Neural Net n, init, Node m ] Input: A Petri net named n, the initial condition of states, and the node marked as m we want to check. Return: True if for Net n, m is reachable given the initial condition init in finite steps, else return False. ClearAll[petriNetReachableQ]; petriNetReachableQ[pnet_, init_, place_]:= Module[ {states, places, assoc}, states = Total[NestList[updateFiring[pnet], init , 100]]; places = First @ Rest @ pnet; assoc = Association[Thread[places -> states]]; If[assoc[place] === 0, False, True] ] An example to run petriNetReachableQ is the following: In[61]:= petriNetReachableQ[graph, {1, 2, 0, 0, 5, 3, 0, 2}, c] Out[61]= True There are other properties remain discussed, such as boundedness and liveness. These are interesting graph properties we want to discuss here in Petri net. For a place p in a Petri Net, it is k-bounded if it never contains more than k tokens in any reachable marking. For example, traffic light nets are bounded, since every places are 1-bounded, which means the system is in safe. ![enter image description here][5] kBoundedness[Petri net pnet, initial state, key p]: Input: Petri net named pnet, initial state of the Petri net pnet and the state key we what to check. Return: an integer shows the boundedness of the state key. For example, we want to check the boundedness of the red light from the Petri net we created, which is 1. In[63]:= kBoundedness[graph, {1, 0, 1, 0, 1}][red1] Out[63]= 1 [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=PetrinetExample.jpeg&userId=1726500 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=pnet.gif&userId=1726500 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=GenInterface.jpg&userId=1726500 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ChemInterface.jpg&userId=1726500 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1.gif&userId=1726500 Pumeng Lyu 2019-07-10T13:40:12Z https://community.wolfram.com/groups/-/m/t/1733095 Introduction ------------ Text analysis provides insight into stories that can be difficult to parse, especially when they are sufficiently large. This project aims to make a program that can use text analysis on any play in order to evaluate the relationships between characters. One can use sentiment analysis on each sentence and incorporate the frequency of these sentiments to determine a relationship's health. Then, a graph with vertices representing the characters and edges representing their relationships illustrates the entire social network. The health of these relationships can be visualized with color, and frequency with width. Further operations with graphing functions can provide information on local groups within the play. In addition, accounting for who speaks to who, visualized with directed edges, allows for nuanced relationships in which feelings are not mutual. In order to test the universality of my program, I analyzed 10 plays of various time periods: *Hamlet*, *King Lear*, *Midsummer Night’s Dream*, *Romeo and Juliet*, *The Tempest*, *Oedipus the King, Oedipus at Colonus*, *Antigone*, *Death of a Salesman*, and *The Glass Menagerie*. Each play is given custom values for a negativity bias, positive tolerance, and negative tolerance so that the final graph best illustrates the play: (* Set conditions specific to play: {play number, negativity bias, positive tolerance, negative tolerance} *) playConditions = Table[plays[[i]] -> {i, 1, .30, -.30}, {i, 1, Length[plays]}]; (* Default Setting *) exceptions = {Values[playConditions[[1]]] -> {1, 1.2, .20, -.30}, Values[playConditions[[2]]] -> {2, 1.35, .30, -.20}, Values[playConditions[[3]]] -> {3, 1.25, .40, -.30}, Values[playConditions[[4]]] -> {4, 1.3, .30, -.30}, Values[playConditions[[5]]] -> {5, 1.3, .30, -.30}, Values[playConditions[[6]]] -> {6, 1.3, .30, -.30}, Values[playConditions[[7]]] -> {7, 1.3, .30, -.30}, Values[playConditions[[8]]] -> {8, 1.3, .35, -.30}, Values[playConditions[[9]]] -> {9, 1.3, .30, -.20}, Values[playConditions[[10]]] -> {10, 1.3, .30, -.30}}; playConditions = playConditions /. exceptions; This project can be divided into two subtasks. The first is to accurately identify the speaker and recipient of a sentiment. The next is to incorporate numerous sentiment values to assess the overall health of a relationship between each pair of two characters. Determining the Characters Involved ----------------------------------- First, correctly identifying the speaker can be easily done for plays, as each speaker is bolded: speakerOrder = Capitalize[ ToLowerCase@ StringCases[text, Shortest["<b>" ~~ x__ ~~ "</b>"] -> x] // Flatten, "AllWords"]; nameList = speakerOrder // DeleteDuplicates; This code captures the speaker of each line, which allows us to split up the text into lines of the speakers. The sentences of each line correspond to the speaker of the line, and they are then split in preparation of individual sentiment analysis: lines = StringSplit[ text // StringDelete[Shortest["<i>" ~~ x__ ~~ "</i>"]] // StringDelete[Shortest["[" ~~ x__ ~~ "]"]], Shortest["<b>" ~~ x__ ~~ "</b>"]] // StringDelete[Shortest["<" ~~ x___ ~~ ">"]] // Rest; sentences = lines // TextSentences; lineLength = Length /@ sentences; Determining the recipient of a sentiment requires making a few assumptions. The recipient of each sentence is initially set to the speaker of the previous line. Then, searching in the order of sentences, a character name within a sentence reassigns the sentiment to the corresponding character for that sentence and all the following sentences in the same line. Finally, the list of speakers for each sentence is directed to the list of recipients of each sentence. Searching for names can be accomplished as the following: emphasis = WordFrequency[Flatten[sentences], #, IgnoreCase -> True] & /@ nameList; diffRecipientPos = SortBy[Position[emphasis, _?Positive], Last]; Calculating the Health of Relationships --------------------------------------- First, we complete sentiment analysis on each sentence: feelings = Classify["Sentiment", #, "Probabilities"] & /@ sentences // Flatten; Using individual sentiments to judge overall relationship health, I assumed that a large number of nonstandard probabilities indicate health, and the more numerous these probabilities are the more reflective they become of the relationship. Experimentally, I created a formula which punishes uncertainty, and rewards frequency: {pos, neu, neg} = Table[feelings[[i]][#], {i, 1, Length[feelings]}] & /@ {"Positive", "Neutral", "Negative"}; negBias = Values[playConditions][[playNum]][[2]]; Health = (pos - negBias*neg)/(1 + neu); sentenceHealth = {finalRules[[#]], Health[[#]]} & /@ Range[Length[Health]]; sentenceHealthFormat = Cases[sentenceHealth, {#, _}] & /@ ruleList; relationshipHealth = Table[Mean[ Table[sentenceHealthFormat[[i]][[j]][[2]], {j, 1, Length[sentenceHealthFormat[[i]]]}]], {i, 1, Length[sentenceHealthFormat]}]; (* Incorporate Frequency into Health *) freq = Table[ Length[sentenceHealthFormat[[i]]], {i, 1, Length[sentenceHealthFormat]}]; freqMultiplier[x_] := (Log[x] + 2)/2; Generating the Relationship Graph --------------------------------- The positive and negative tolerance values filter out neutral and conflicted sentiments. The calculated health of each relationship can be converted into a color ranging from red to green. Blending with gray allows one to more easily visualize health as brightness instead of color: viableRel = Position[relationshipHealthFinal, x_ /; x > posTolerance || x < negTolerance] // Flatten; relationshipHealthFinalExc = Table[relationshipHealthFinal[[i]], {i, viableRel}]; viableFreq = Table[freq[[i]], {i, viableRel}]; relationshipColors = Table[Blend[{Red, Gray, Green}, (i + 1)/2], {i, relationshipHealthFinalExc}] viableEdges = Table[ruleList[[i]], {i, viableRel}]; edgeColors = Table[viableEdges[[i]] -> relationshipColors[[i]], {i, Length[viableEdges]}]; Producing a community graph plot illustrates clusters of characters with strong feelings toward each other (not necessarily positive): ![Romeo and Juliet: Relationship Network Graph][1] Conclusion ---------- The necessity of a negativity bias suggests that the Wolfram sentiment classifier may have a positivity bias. Also, by human evaluation of the plays and the respective relationship network graphs, Shakespearean works appear to generate the most accurate graphs. This may be due to the text structure of the different time periods: perhaps using sentiment analysis on each sentence was too large of a unit for Greek plays that employ long, winding sentences, and too small for modern plays that utilize rapid, stichomythic dialogue and interjections. Extension --------- As such, the size of the text used for each calculation of sentiment could be a function of sentence length. Additionally, setting the values for health parameters can be automated. Furthermore, one could handle the cases of having multiple recipients for a sentiment. The most difficult avenue, though perhaps the most fruitful, would be to catch pronouns, aliases, and titles and assign them to the proper recipient. Once completed, a novel can be analyzed by using a similar process to determine the speaker in addition to the recipient of a particular sentiment. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=RomeoJuliet0.png&userId=1724914 Jason Zeng 2019-07-12T02:06:25Z https://community.wolfram.com/groups/-/m/t/2964488 ![Comparison of Routes Within Washington D.C.][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7.13.23TitleImage.PNG&userId=2964405 [2]: https://www.wolframcloud.com/obj/244e570a-362b-4c38-b265-56e5db82de19 Ryan Tong 2023-07-13T21:39:54Z https://community.wolfram.com/groups/-/m/t/1382524 ![WordCloud.][1] This is a word cloud of the frequencies of the most common mathematica functions. #Introduction The purpose of this project was to scrape the example data from the [Wolfram Language Documentation Center][2] and to retrieve function names from the cells, for analysis. This included looking at functions that were commonly used together, factoring a weighting system similar to TF IDF where the more a term appears overall, it has less value, and as a result, function use is balanced out accordingly. Also, a community graph plot was made, visualising connection across various functions, and attempts to group functions that have similar links, with some exciting results. #Retrieving the Data Since the documentation lies within the file explorer, they can be found and imported with the following code: files = FileNames["*", FileNameJoin@{$InstallationDirectory, "Documentation", "English", "System", "ReferencePages", "Symbols"}]; The data must then be refined and processed with a function that imports the cells, deletes image cases (this is because they tamper with the list value) and hold the function to ensure it does not evaluation like so: getSymbolData[notebook_] := Module[{expressions, noImages},(*Defines expressions and noImages locally*) expressions = NotebookImport[notebook, "Input" -> "HeldExpression"]; (*Imports one given notebook by it's \ directory*) noImages = DeleteCases[expressions, HoldPattern[Image[_RawArray, ___]], Infinity];(*Remove images so they don't clutter the list data*) (*Counts up functions used inside other functions e.g Plot[Sin]*) Counts@Flatten@Cases[ noImages, (f_Symbol)[args : (_Symbol[___]) ..] :> Cases[ HoldComplete[args], (g_Symbol)[___] :> HoldComplete[f, g]], {2, Infinity}]] With this, we can introduce functions that seek lists in the form {symbol1,symbol2) and scan across every function to create a graph of relations. MutualFunctionUse[sym1_, sym2_, functset_] := Cases[functset, {{sym1, If[sym2 == "", _String, sym2]}, _Integer}] And further shorten the data by selecting the functions that appear the most with the specified function. ![Tada!][3] # Visualization The data above can be easily manipulated into a graph with the edge weighting being the second item in the main list and the edge connection being the first connection. functionGraph[x_, n_, functset_] := Module[{edges, edgelabels, sizes, mutualfunctions, graph, finished}, mutualfunctions = functiongather[x, functset, n]; edges = Thread[mutualfunctions[[1 ;;, 1, 1]] \[UndirectedEdge] mutualfunctions[[1 ;;, 1, 2]]]; edgelabels = Thread[Thread[ mutualfunctions[[1 ;;, 1, 1]] \[UndirectedEdge] mutualfunctions[[1 ;;, 1, 2]]] -> mutualfunctions[[1 ;;, 2]]]; finished = Thread[Part[edgelabels, All, 1] -> Evaluate@(Placed[#, Tooltip] & /@ (Part[edgelabels, All, 2]))]; sizes = Append[Thread[ Evaluate@mutualfunctions[[1 ;;, 1, 2]] -> (#*0.1 &) /@ Floor /@ Log /@ Evaluate@(SymbolFreq[#] & /@ mutualfunctions[[1 ;;, 1, 2]])], x -> 0.1*Floor@Log@SymbolFreq[x]]; graph = Graph[edges, VertexLabels -> Placed["Name", Center], VertexSize -> sizes, EdgeLabels -> finished, Background -> White, ImageSize -> Full, EdgeWeight -> Flatten@mutualfunctions[[All, 2]]]; {CommunityGraphPlot[graph], MatrixPlot[WeightedAdjacencyMatrix[graph]]} ] Most of the code above is for visual effects, such as a tooltip that appears when hovering over the graph. Most of the threading is done to describe the process before, just to connect it in the form symbol1 - symbol2 -> edgeWeight and the sizes were all processed through the logarithm function followed by a multiplication of 0.1 to scale nodes to size. The parameters functset is used for convenience, for example, if the user inputted a filtered version without incredibly common functions such as List to pollute the pool, it would return a different graph, and the n selects the top n used functions. The function also returns a weighted matrix plot of the graph, like a heat map which is hidden as the graph takes up the full window. Here is an example of function graph: ![List is the primary function][4] The code can be further extended to process across several functions, joining to make a bigger community graph, revealing more relationships and communities like so: allfunctionGraph[x_, functset_, n_] := Module[{edges, edgelabels, sizes, mutualfunctions, graph, finished}, mutualfunctions = functiongather[#, functset, n] & /@ x; edges = Thread[Flatten@mutualfunctions[[All, All, 1, 1]] \[UndirectedEdge] Flatten@mutualfunctions[[All, All, 1, 2]]]; edgelabels = Thread[Thread[(Flatten@ mutualfunctions[[All, All, 1, 1]] \[UndirectedEdge] Flatten@mutualfunctions[[All, All, 1, 2]])] -> Flatten@mutualfunctions[[All, All, 2]]]; finished = Thread[Part[edgelabels, All, 1] -> Evaluate@(Placed[#, Tooltip] & /@ (Part[edgelabels, All, 2]))]; sizes = Append[Thread[ Evaluate@Flatten@mutualfunctions[[All, All, 1, 2]] -> (#*0.1 &) /@ Floor /@ Log /@ Evaluate@(SymbolFreq[#] & /@ Flatten@mutualfunctions[[All, All, 1, 2]])], Thread[x -> 0.1*Floor /@ (Log /@ (SymbolFreq /@ x))]]; graph = Graph[edges, VertexLabels -> Placed["Name", Tooltip], VertexSize -> sizes, EdgeLabels -> finished, Background -> White, ImageSize -> Full, EdgeWeight -> Flatten@mutualfunctions[[All, All, 2]]]; {CommunityGraphPlot[graph], MatrixPlot[WeightedAdjacencyMatrix[graph], ImageSize -> Full]} ] The above code is just a generalization of the first function, with list processing being added to accommodate for the list of inputs. While there are no labels, function names and connections appear as one hovers over an edge/node. ![More function graph][5] The final visualization is a weighted bar chart that takes in a function and returns a bar chart with weighted values, which is the quotient of the function's frequency with the specified functions and the functions general frequency across all cells. The weighting system is simple at this stage but can be improved to further avoid symbols such as List or Power polluting the sample space. ![Last one][6] #Errors and alternative pathways Many of the issues faced were time complexity related, with inappropriate sorting algorithms being utilized which unintentionally increased the runtime far more than should be expected, for example the initial algorithm would run in a time approximately cubed to the input but could be easily optimized to run in quadratic time, which could have the potential to reduce the run time from 50 minutes to less than a minute. The unoptimized algorithm was the primary bottleneck, as importing over 5146 files with an optimized algorithm would be inefficient and would become useless if the model were to take in a larger data set from other websites or files. #Conclusion & Future Work The data-set used was small, and intentionally designed as examples, which led to much more to be desired. Other sources of function usage such as the Mathematica StackExchange or wolfram alpha would greatly expand the database and also allow for more detail graphs. This is a small stepping stone to a bigger project which entails using machine learning to register user input to understand what function they want to use, and the graph provided has insight into navigating through keywords and the desired function. Credit to Richard Hennigan for providing the scraped data and assisting me with the project. Github link to the notebook: https://github.com/Theorvolt/CommonlyPairedWolframFunctions [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=yeet.png&userId=1372480 [2]: http://reference.wolfram.com/language/ [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=example1.PNG&userId=1372480 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=example2.PNG&userId=1372480 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=example3.PNG&userId=1372480 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=despa3to.PNG&userId=1372480 Sai kumar Murali krishnan 2018-07-13T13:39:07Z