2018 Internal One-Liner Competition

Variable names used in some submissions may clash.  If an entry doesn’t not appear to work, try quitting the kernel to clear all variable definitions and evaluating again.

1

Jesse Dohmann

ListContourPlot3D[Partition[IntegerDigits@GroupOrder@MonsterGroupM[],3],Contours->RandomInteger@9,Axes->False,Mesh->None]

2 Lucas-Lehmer Mersenne Prime Test (for the first 99 primes)

John McGee

(p=#;m=2^p-1;{p,Nest[(k=#*#-2;
While[k>m,k=BitAnd[k,m]+Quotient[k,2^p]];
If[k==m,0,k])&,4,p-2]==0})&/@Prime@Range@99

3 Elliptic Curve Explorer

John McGee

Manipulate[Plot[{-1,1}Sqrt[x^3+a x+b],{x,-5,5},PlotLabel->Row[{"E:",y==x^3+a x+b}]],{{a,0,"A"},-9,9,1},{{b,0,"B"},-9,9,1}]

4 Evolving abstract art

Jon McLoone

i=RandomImage[1,300,ColorSpace->"RGB"];
Dynamic[i=ImageRestyle[i,i]]

Below is not the entry, but if you ever want to show a static single-image version of what the code above does, it sums it up well...

ImageAssemble[Partition[NestList[ImageRestyle[#,#]&,RandomImage[1,300,ColorSpace->"RGB"],16],4]]

5 One liner! snake

Jon McLoone

p=Table[m={3,3},10]-1;
Dynamic[
Graphics[Thread[Text[Characters["One liner!"],p=.9p+.1Most[Join[{m+=RandomReal[.2,2]-.1},p]]]]]]

6 Chaos

Jacob Wells

Manipulate[Graphics[Polygon[Part@RandomPoint[Disk[],x],Flatten@FindCurvePath@RandomPoint[Disk[],x]]],{x,20,1000,1}]

7 Surprisingly short Minesweeper code
WARNING: Opening this cell will corrupt the character counter at the top
of this notebook until the cell is closed and the kernel restarted.

Jon McLoone

“Surprisingly short Minesweeper code”. It  may look longer but scores only 47 characters. Go on check! And, I promise, I haven’t changed the submission template, you can copy the code into a fresh OneLiner template and see.

DynamicModule[{$GameTime=0Surely deserving of a dishounourable mention!!!,$Time,data={{}},display={},neighbours,$GameState="Start",$GameData,h=9,w=9,n=10,bombchar=,flagchar=,cn,ch,cw},
Manipulate[
If[cn>3ch cw/4,cn=Floor[3 ch cw/4]];
If[$GameState==="Start",best=Lookup[LocalSymbol["MathematicaMinesweeperTimes"],game[h,w,n],∞]];
Dynamic[
If[data===(display/.{"show"->0,"flag"->1}),$GameState="win";
If[$GameTime<best,
best=$GameTime;
AppendTo[LocalSymbol["MathematicaMinesweeperTimes"],game[h,w,n]->best]
]];
Column[{
Dynamic@Style[Row[{"Mines: ",Total[Flatten[data]]-Count[Flatten[display],"flag"]," ",Framed@Switch[$GameState,"lose","☹","win","☺",_,"😐"]," Time: ",Refresh[If[$GameState==="Play",$GameTime=Round[AbsoluteTime[]-$Time]];DateString[$GameTime,{"Minute",":","Second"}],UpdateInterval->1]," Best: ",best}],20],
Deploy@Grid[Table[
Quiet@Switch[{$GameState,data[[x,y]],display[[x,y]]},
{"Start",_,_},clickItem[
While[data=Partition[RandomSample[Table[Boole[i≤n],{i,h w}],h w],w];data[[#,#2]]=!=0];
display=ConstantArray["hidden",{h,w}];
display[[#,#2]]="show";
neighbours=ListConvolve[{{1,1,1},{1,0,1},{1,1,1}},data,{2,2},0];
$GameTime=0;
$Time=AbsoluteTime[];
$GameState="Play"]&[x,y],
{"win"|"lose",1,"flag"},flagchar,
{"lose",0,"flag"},Item[flagchar,Background->Red],
{"lose",1,"hidden"},bombchar,
{"lose",1,"show"},Item[bombchar,Background->Red],
{"lose",0,"hidden"},clickItem[],
{_,1,"show"},$GameState="lose";bombchar,
{_,0,"show"},If[neighbours[[x,y]]==0,
(If[Extract[display,#]=!="flag",display=ReplacePart[display,#->"show"]]&/@neighbourPos[x,y,Dimensions[display]]);"",neighbours[[x,y]]],
{_,_,"hidden"},clickItem[display[[#,#2]]="show",display[[#,#2]]="flag"]&[x,y],
{_,_,"flag"},clickItem[display[[#,#2]]="show",display[[#,#2]]="hidden",flagchar]&[x,y]],
{x,1,h},
{y,1,w}],
Frame->All,Spacings->{0,0},BaseStyle->{20},ItemSize->{1.6,2}]}]],
{{difficulty,"Easy",""},{"Easy","Medium","Hard","Custom"}},
PaneSelector[{False->Spacer[1],True->Column[{
Control[{{ch,9,"height"},5,50,1,Appearance->"Labeled"}],
Control@{{cw,9,"width"},5,50,1,Appearance->"Labeled"},
Control@{{cn,10,"mines"},5,400,1,Appearance->"Labeled"}}]},Dynamic[difficulty==="Custom"],ImageSize->Automatic],
Button["Start",$GameState="Start";data={{}};display={};{h,w,n}=Switch[difficulty,"Easy",{9,9,10},"Medium",{16,16,40},"Hard",{16,30,99},"Custom",{ch,cw,cn}]],
Initialization:>(
clickItem[leftMouse_:Null,rightMouse_:Null,char_:Panel["",Background->LightGray,ImageSize->{32,32}]]:=Item[EventHandler[char,{{"MouseClicked",1}:>leftMouse,{"MouseClicked",2}:>(rightMouse)}],Background->LightGray,Frame->All,ItemSize->Automatic];SetAttributes[clickItem,HoldAll];
If[Not[ValueQ[LocalSymbol["MathematicaMinesweeperTimes"]]],LocalSymbol["MathematicaMinesweeperTimes"]=<||>];
neighbourPos[x_,y_,{h_,w_}]:=DeleteCases[Flatten[Outer[List,{x-1,x,x+1},{y-1,y,y+1}],1],{___,0,___}|{_,w+1}|{h+1,_}])]]

8 Reddit music

Marc Vredeveld

This one-liner, scrapes Reddits json API for post titles, randomly selects one and converts it to music. Results are more interesting for longer titles!

Sound[SoundNote[3*#,#/30]&/@Mod[LetterNumber@RandomChoice@Cases[Import@"http://reddit.com/.json",("title"->x_):>x,8],8]]

9 Word Puzzle or Scrabble Solver Web App (Where You Enter Your Letters in the Input Field to See the Best Words to Play)

Kelvin Mischo

CloudDeploy@FormPage["letr"-><|"Input"->"froawml"|>,Select[StringJoin/@Permutations[Characters[#letr],{2,7}],DictionaryWordQ]&]

10 Swarm of Flies

Danny Finn

x={0,0}~Table~9;r={-9,9};Dynamic@ListPlot[x,PlotRange->{r,r}]
Dynamic[x=Clip[x+{-1,1}~RandomReal~{9,2},r],UpdateInterval->0.1]

11 A function a day

Abrita Chakravarty

Please find attached my entry “A function a day”, it will email examples from one WL function everyday to your inbox to help you learn the Wolfram Language :)

CloudSubmit@ScheduledTask[SendMail@WolframLanguageData["RandomEntities"][[1]][{"DocumentationBasicExamples","URL"}],"Daily"]

12 ImageGuessr (Wolfram Pictionary)

Danny Finn

Can you guess the word based on the pictures? The better you do, higher your score!
This makes use of semantic features (meaning of the word) to compute how good your guess was!
Enter your guess in the dialog that pops up.

{w=RandomWord[],g=ToString@Input@ImageCollage@WebImageSearch[w,"Images"],Dot@@@FeatureExtract[{{w,g}},"WordVectors"][[;;,;;,1]]}

13

Lou D’Andria

You’ll need to be on the internal WRI network, and log in when requested.

Labeled[#,Classify["NotablePerson",#]]&/@Import["https://bizi.wolfram.com/admin/personnel/people/images",{"HTML","Images"}]

14 Next Twin Prime

John McGee

NTP[n_]:=Module[{p1,p2},{p1,p2}=NestList[NextPrime,n,1];While[p2-p1>2,p1=p2;p2=NextPrime[p1]];{p1,p2}];NTP/@NTP[2^50]

15 Relativistic Redshift/Blueshift

Duncan Pettengill

This line simulates the effects of relativistic redshift/blueshift on a test image, in this case the Mona Lisa.

Animate[Image@Map[Dot[#,List@@ColorData["VisibleSpectrum"][f #]&/@{630,540,465}]&,ImageData@LinguisticAssistant@"Image",{2}],{f,0,2}]

16

Noriko Yasui

ListPlot[Tooltip[#[#<>"ContentPerServing"&/@{"Iron","TotalProtein"}],#["Name"]]&/@EntityList[Interpreter["Food"]["cereal"]]]

17

Daniel Robinson

Here is a one-liner. Some notes:
	•	Upon initial evaluation, the character count incorrectly displays as 1 (until you type something and press enter).
	•	It counts new lines as characters (but then, so does the original).
	•	It doesn’t count spaces when they’re inside quotes (while the original does).
	•	It doesn’t change ‘characters’ to ‘character’ when the count is 1 (but then, nor does the original).

a=Dynamic;b=ToString;{InputField[a@x,String],a["One-Liner count: "<>b@StringLength@StringDelete[b@x," "]<>" characters "<>"☺"]}

18

Jonathan Harwood

m=RemoveBackground[];
i=CurrentImage[];
b=FindFaces[i];
If[b≠{},HighlightImage[i,Inset[m,Sequence@@First[b],Scaled[.85]]],i]

19

Robert Sandheinrich

GeoListPlot[Cases[TextCases[WikipediaData[#],"Location"->"Interpretation"],_GeoPosition]&/@#,PlotLegends->#]&@{"Romans","Huns"}

20

Daniel Carvalho

Animate[Plot3D[Sin[f+x]Cos[f+y],{x,0,2Pi},{y,0,2Pi},ColorFunction->"DeepSeaColors"],{f,0,Pi}]

21

Daniel Carvalho

ImageCollage[Flatten[FindFaces[#,"Image"]&/@WebImageSearch["portrait","Thumbnails",MaxItems-> 16]]]

22

Robert Sandheinrich

{m,f}=ResourceFunction/@{"MoveMouse","ResourceFunctionDefinitionViewer"};
m[f[m],{200,200},{"Click",{"Type","Bob Was Here"}}];

23 Notebook Pox

Danny Finn

Evaluate the following to get notebook pox

SetOptions[EvaluationNotebook[],System`BackgroundAppearance->Rasterize@Graphics[{Red,Disk[#,0.01]&/@RandomReal[1,{99,2}]}]]

Also here’s the cure to notebook pox

SetOptions[EvaluationNotebook[],System`BackgroundAppearance->None]

24

Sarah Stanley

Merry Christmas to everyone!

WordCloud[Join[Values[WordTranslation["Christmas","English"->All]],ConstantArray["MERRY",20]],ColorFunction->"DeepSeaColors"]

25

Sarah Stanley

Bringing a white winter to the rainforest!

ResourceObject[a="CycleGAN Summer-to-Winter Translation"];ListAnimate[ NetModel[a][#]&/@WebImageSearch["rainforest","Images"]]

26

Sarah Stanley

Tigers CAN change their stripes -with a little help from a multitasking zebra erasing neural net, “CycleGAN Zebra-to-Horse Translation Trained on ImageNet Competition Data”.
 *Results may vary. Currently only recommended for white tigers.

ResourceObject[a="4b148040-10cd-43e2-8152-1a31c675cec3"];{#,  NetModel[a]@#}&/@WebImageSearch["white tiger","Images"]//TableForm

27

Abel Nazareth

My goal was to make any image look like a cartoon like image.

URLShorten[CloudDeploy[FormPage["img"->"JPEG",ImageEffect[#img,{"Posterization",3}]&],Permissions->"Public"],"CartoonLike"]

28

Emmanuel Garces Medina

Animate[Column[{GeoGraphics["World",GeoProjection->"Orthographic",GeoCenter->{0,l}],TimeObject@{l 0.066,0,0}},Center],{l,0,360}]

29

Emmanuel Garces Medina

GeoBubbleChart[EntityValue[CountryData[],"Area","EntityAssociation"],ChartElements->EntityValue[CountryData[],"FlagImage"]]

30

Emmanuel Garces Medina

p=Reverse/@RandomGeoPosition[LinguisticAssistant,2500][[1]];ListAnimate@Table[GeoGraphics[{RGBColor@@RandomReal[{0,1},3],Point[#]}&/@p],33]

31

Arash Mahdian

GeoRegionValuePlot[Thread[EntityList[LinguisticAssistant]->LinguisticAssistant],GeoLabels->(Tooltip[#1,#2]&),PlotLabel->"% of boys"]

32 A little fun with motion

Brian Wood

… Just a little fun with motion.

Manipulate[With[{c:=CurrentImage[],p:=Pause[t]},ImageAdd[(p;ImageMultiply[c,#])&/@{Red,Green,Blue}]],{t,.05,.15,.01}]

33

Jofre Espigule-Pons

ImageCollage[#["Image"]&/@(EntityClass[s="Species","Mammal"<>s][e="Entities"]⋂LinguisticAssistant[e]),Method->"Columns"]

34

Jofre Espigule-Pons

ImageCollage[#["Image"]&/@Union@@SpeciesData[{LinguisticAssistant,LinguisticAssistant,LinguisticAssistant},"TaxonomicSequence"],Method->"Rows"]