10
$\begingroup$

I'm trying to plot a 3d revolution plot from a set of 2d points. These data points form a 2d curve, then we rotate that curve around y axis and get a 3d surface. @J. M. has a well explained and very helpful post at here which deals exactly the problem I have. However, I tried to use the method, and get a 3d surface that is very rough and not smooth.

Here is the 2d data points:

points=Uncompress["1:eJx13Hc4lX/4OHAjW7JnhKRCpEIazrESokhCpUhZFR6KhLLik6w0NBSVShItoew9I7KyRcnWkozffY7v9/yuy/11/uJ6Xeec5zzPe9zv+z2kbF1Mj1cy0NG5L6Gjo9vl6O5xHP75//8RdP/zIthqIqQ/+0vkLfBLe+8n2IXeJBGHIt9WjWPnmTQW8VO6RSI2N3DYTGBXdrHfWfU5iURI5U2wswUgJ7HRV+oYvCIRno5F8Suwbz8vrxN8Hjz4Z/MhSezzn59JIra8NP+hir0mp0p1s0geiYjWrvMwwr41nt7/mjr4R/5HVsbYj8UYqbbYFZKIvQ+zPtthp/srzGocXkIiksU7dp7DXm417qP3CjyH0Nb3Xuz6y0kEs8qSs0L4/mU9C2Bjn6oiEZLfv5M9zyN/v1yw5qxqNYlQGLiXvR/7+URyyuG1tSSi0+RrY5Iv8u8lEaw2d+tIxOkpraiNPsj7ZBltr0+ANwfa5n4+t8j9qScR+/K2MYl4I+9K7mu/k9tAIvarV7UMeiGPKhcv4jH4RCJI1eSgA9gN/a1yTeMbSYTaFi39qDPIfY4VntjS0UQiakwvWu05jXxDDOtr/YfNJKKM59jbQI9F7n8Libj/8kbIMnfkcqumSvfNtJIIlvDKq0VuyEXVC3tGZz+TiFKrVOm7rsiFD3nU6Qq1k4i/B/+mm7sgl55d4dcu1kEiHJ+espI9hTylIOl3vmUniTBdbcbz6sQiz7eLRCRc+aUZ5Yy850lCrUgcuJTni2F/J+QrZHcyGVh1k4i2H5NzpQ7IieWlbstLwQ3KxqvK7ZG/Mt3Yo6PQA+VD++eF9uPIB5y2LnvF0ksi7PPiRtrsFik/4E+3nb7EiT1wuuiHyzvwSG41fvWjyD+Eu7LUvP9CIpwEXtowHUZuwd4wdY2hj0S8+ch8pPcQcmOJ+j4lErjuv9jOzIO4/A6d2l3i3U8ijoo1XPhtvkj5BA+0Pd1oij02bdO5zDxwsYIPfCn7kFtmj21dof6NRNDrfjrzwRi5xmRX4DINcEaTd1feYr9mFyhirAVuXafJ/gD7ilNL133wAd8JtznGCHnGRpn+Yc4BEjF6c9P9cQPkp+P7FHILwW8WTIpH6S1Sf8BTPiqWrcAuY/6+7v4f8LDpwIK4HciLyalHQnQGScTY5fK/pmT8fri6/86CNw4urdlDQr7tsWFHdzo4Q4n/+u0ayCcu2o5FFg+RiNy8q0Or1JELUevnMLSfW0P876ghv/Vlg4DeGXD7qwN89SrIL9+/P2e5Y4REDKzVJg0oI6cWvzfg0jma7g1KyCelRHc9UxklEdW2Jn8c1uH2J6eHS6YUnC9mPPqZ3CL1f4xECGtO23GuQZ6ceiE/1Bt8g3Jm66wM8t4TPMv+PADfPn3vi8tKfH2U4jcJPvoo0yFxBfLWgMa1OtbjJMKiL3V/lChys2ssAw1HwLOIs/Eu2D/SGfcPOoE7UcqRyCLtDzi9nJbINX7k9C52gh6iEySiXpOZuXYZ8pM9Ij0NeuCG9akKakuRD+2nPCFwn/dDvdmsuP3dma/N1wA+xB3jvJ4J+fFfb2+5Kv+A8m0f4N88J/5/t2/gNZcNjb5OIx/I+i2dFg5upMD5NHIKedvRFj4usZ8kgtOY77fXBPKOmqjYtxvBH7oZinGOI0/a+CxPXw983KBYb3gU+Zuxy4fVJsDD4GNk+pGPHBsY76f7RSLMd2il7upDPt++gg/KMp1VwT7Go2f3egl4Lv/sLD92/sHvDieywBWcE9TjW5F/1KXUUPC9BhZ6u1rw9fWfUyVGwGf0mPQSm5C7FPwInHL/TSLE1ZcITn5APt9+g3PJua1xrEZutTrl+vpm8EBdrp0qFcgnLg5+Clz3B+IH345wo2LkRe/jpJRdwP1W7Ji5mI+8xL7j90g+OLu2kH7xe+Q566W/jvSDV26y6IvJQj7fP0ySCH2xnV+yXiE3it0UmnIT/FNF7pKgZ8gbr4e2Zb0B1yg/GmL8FPl8//CXRLh/Lk93fYCfX7vYgeO7wH0+8Gx3u4vcy9c2UScZ/Km7cMPkdeTz/Qd43G3D/2RjkLdKMSqumAOXbjh62joKuZjdtlM18VMkQlCiWvJBIPKn1Bd4yYHqA20B+P4v3x3a/AK8baPDuCH2HUuKTzt1gtdQ2nE/5NRWi/cfifi8lUv3rTf25Lr6KDtw13aW/s0eyOf7N/Axsd2KVwj8/A0E1Syug/uX+Z80ckX+PNlmh6XQNPSPJMWRdceR35Wi3GHw3A8bL8fZIg9bw1leHwa+3/PJp9mDyC/5ZbNLVoCHhm1ZIW2BfL7/nCEReld8tThMcf2X0XULcgMfk2dymjFA3tAqsmbUh+JipT6i2FnISnqy/uDm/2WUFukjj6I2W+Aat0Y5vmgi/9LSUtCoNEsi3vkyiazYhuvHnlXasZ7gYxKdU1MqyOf7b/BLeZ6xXMrIL7Q+E9/SBb7riNG1bgXcvqrvyTLxnIP4X8/ZNVwcedAySg0GD7r6WENvOfKlcS3BGy+DN67UEnYRQ16RolGs9gach/ogkFf/snKSW05HJg6nRERwsyOfjx/Aq9svlVezINd3HT93Yju43pVCBnVGXP+jReT5CPCBp/ISlyaXo/hM2xa6KHAeneq90j+Qvy3MEl2fC36tTezal2/IrSaUOpeVgROnJBOEviL/S23+wN8frgjh7EAuLiRTYy5BTyY8f01Yj35C3nVAL6SWDC7Xk2b5qgZ5uh/lBoG79xSxRZQhb057oazgAX5m3Dp6XxHy605GFm8LwJXdqjK3vkbuTo1vwGe5yj4dfIU8hPWTHVsFuEPykZjCl8gP/2YzOtIMbkYZJqcil492NLsoyUAmdl+vN6lLQL4+69v9MEXw6yNpMar3kJdmbLFr1gbPzqPr/O8Wct4bjMYlZ8C9Zw1F70chH6bGV+BTS6PEYv5DzslrTb+qHFyVaY545oP8yH4md/YKcHYpBS5P7E9/UdoV8IupJsu43ZBb3H/hc1KckUzsqEnvd3JArnieT2O1KXitirO9yAHk9tT4DbyFXlom0xz5huO8B5VdwW1//rqauxe5Y2V2nPId8BvUhhj//uVMTNkF4H6cpZxtGshlqB0keDlfNuP5bcjvns0UX94GLt7SnxGzGX++3AbPboElZKLA56NRtBzybmr8CC42FM61byXy8yxb3MOPgf/9FnI1WhD5nXumzlcdwK+a1XF/EsDXd+Jluext8EKGFf6/2ZDHHo9X83gH3uA7k6xLj1wks0+EexR8+acZCb+fYgv9ALV4MZGJiMK1XdxjyEVv6bw/xQV+k+/CXO0Q8s+7r8Z93Q7eSmlHupAbxL58rm0DzulRlafajFz4CaUAgr9Y1+Df/gn5BYHNiiVe4IRg9Va1j8gtKkIqe16BH2K98Ox4IfJP1PiXiVL/zAP8spB7u61ocZwBn35NaamQ66Vb/z3IyEwmIs1VktySkTdyMZhHsoK3Zsnotichv9K7OaJ3M3iSuGmP5W3kOk7Vl96ZgteeCGCziUFuaj5dsToOXJRnF/1rH+S7qfE3eP5/mZ2l5/DvV5OXZrkP/uBOjst27BdH3+k8fwwuTg2kkCtbJRtfGQfXlBJ3tjyKnHOFz1g+CwuZ2Le8mT/tIPIVAnvotiuDs42JzCzdgzyPLN39lwzO70RUmRgiL6fG/+BOw6I8TtuRD93zKPOJAg+QfxBwbCPycIbIUqVicMv46eOXVuLfT02Pgts9jpUylEAuNFeSOtcJPj5Uv/msGHK+6mFD2TnwI9RAFrnd2j2D+9lZyYRNUFPSOy7kWtYiNwKUwA8/XzJ6mRG5NnV8Am5tI7hBYU50oU+NVkdIW4In7emsZf6D/FS2sx/TefAaF5XE+EHkdNchKk8ED/WxYDjVgTzoM7HmbRX4mjFRid465L+sZMgKP8GdA5/uOVGIPJs6/mGD57t1v7BlFvLrvW3n7IXBfayOkmXSkUfsFxd+owb+gDoQQf54cMcHITvw2qJk22O3kHvXURoA8JSLpRGuV5Fb/RR38rwBXhDycX9UCPKMH2nSZangMko/gx75IVejjr/Av0pe/Bp4Cnn5P9EzXv/AvW5ue/zVFnlhuNDVgi3sZELo8pT1a0PkP6FSbtUGr4sR331zJ/JO1RSvdXoUp/6BfEJtYlunCXg/9YOQf4RC++MM+A6jAYaHKsi/c4wub7kCLnmqetBRHvkL6mMBz2J+k/5cGrn8ap6cpR3gJ6OkjzcvQz5+Vkv+EsUdNebKkrGfolYrDjLx46EJj+aMyELfY7OeNVYOnCO00sPgJ3IW402pwSfB11IfFPKV68weHDoDLpVe3RHfjFye2iyC09/pIpOakIsbPXlR7Q+uxpryIKQe+VdHwup6DvjqfRV2TpnIv1G7TXDrwQdslU+R79fPPnGNmZNMfL7+Q3fqJvJ8ztyIms3ge/rf/vkViDyRGjaB893+1UP2xe9/y+ISbQwear9cKMQbuYRq+LD/QfAT1IqE/N2ES17ydfDiJUfVNhxAbksNq8EzVq86ZLwH+cC+vckvOsDVKmTGy7Yiv7ZNq6trFFzdzLzJdBPyFdRh21Jon2ydbnitxO/feEqwXhZ8FbuE/LnlyEdHeSpuG4CnUhsq5FktRzVHT4GH807IrJkRXuht1LQG+P1Vaf+MfyMPXP+wLPUROMusgOSPL8jvi53g5HoLnpHenNPUjvwmdXwOvnrvseFj5cjDDnk0KcyB91rlWoTkIHcPMtp7dSMXmZigXGci8ksa9f+mdMBl704b9t9Bbk6d9gD3dW2tMo1FHvTK6GyOI3iRcET83v+QP5i4ctk7FDzw9a3k317I+aj5AfAmgfpdmjbIsx+Zik9VgndWbOZg2Ye842vfFfE/4CrUjhJ5kxXv87PLlpGJbd2NTkLKyGvdKANIcOV3lVVKcshnlG9rTOwAZ91syxnJh/zLy+YE1r3gl2+fW6e2FHk4NT8B7u3Qu+baD6GFvmRq+9Gy6+CjOrnZIQPIPXo5lu/LAveiBirIj6qz99m2gkf3O3K9KkZukHIYIhBwF/5DEY3vkddLrh0c4uImEyImUTVZCcgZRoTkvXjAc+VHV9HdQx5IzX+AiwcZ+fNeRG6Zy/voy3pwhzFNvq1+yFs1Vb2aNMDfUQM95Nyj0XlbTMEFX0oIeVkit6VU/0Pgk3PDF2IM8fVbxyq9cgPXmGAr+rseOZfZuzfqkeC2M+WaQ+zIydT8C/jWLTc1elnx9RcTLbLR4Btk4vrdsB+IveaSSvFZCUqgjDzYttUjJQ28KtdgaFmXIGp/oXe+WAQu6lct+LAEeclgFZtcLXj0Jq6+m2+Rd09Oae7uAdekDhSQh+pfGkseBbcwtfdXjEQ+Q80Pga9Z+rxQKQi5wWO9pnXLeMiEhGueeOFx5OYOahzeK8AjiR+lrSbI21L5YQQIHuBoe7BZEzknE1NOqiL4l3CRrP0ayD94JfGObQAPog60kNfYFjxUNgZPTibMhwSQZ1HzU+D8jxSXNU0JLHSndLqmMWfwNW+q//s3gJw9xrZP6hx4KXWgiVzIsDMgIhS8mOyYVvoOeSwlPRID/iBmdPfOp8hLiuPH194G/wbF4H0c8uLObEWFRHDbqiVNMeHIWd9QfiB49GUJ2dALyP0nO2aU34GzUwfiyAmPO63l+eBz++NnDh9G7knNv4H7BxtNl5oj3y4vzr7lM7gCpR9RRf7qgNR1+w7wktBQbQVl5Cl1Lhwsf8Hvbn84qcSM3HyQkiADP+yZ/ESPEXlVnOUGpn/g6i5NBpMMyCcPHRDUorgRNRGC3MAinP+BEC+0vzvEO4oa+Bf6Jmr+D9yGWfi/ilTkZ5pZu3U2gfMlTejefIS88ar06j1bwaOoiR7kIXRWuxN2g3sfcB/vOY2clxLV24LvCovb8dAYeaHmMYteB/BNZIePf8jI675YbzF0Aa+nJrKQ99s83i8ZAJ7dU3GPgRP5ODU/Ce63vzxatocP9e9qavusboNbjZY5sjQhv7Jh7dGweHBBaqIO+UY9xq3Rr8E73EhLmO8jr5W9DTcOnHXj1M2Tp5Hzs0tOFFWDd1nu15w9gVz58fLYV3XgltREJfKmm6SmmX7w5M8erXSbkT+n5k/B975WGwtjQ97Ts6/Sjo6PTDDVno8+zIjvT6/4PR5G8DvzH7TQV30O9y0SAH8u58D/pgr5x2r3+3xC4GtYb3EZlyM/3mRzpG8NeOf8g1roOvKz6ooK4Marwjn5LyO/TJ2ABaefiSJW+yJ3fKqULqoJ/jm4pt7XGDkL/zlF9l3g0vMVZaGTCs7l85qDVwjpZs5yI3eefyxkwvzIlvclfTwLXcXzyGo+Z/DJ3qG9UfXIvRoT5sxcwI/NN1QLXU5BN5zvArhs2tURqevI100X7pgLBu8yaN1TG4ScWYosU3oF/Ml8R7LQo+lzBYaugqtlH685aoHcgBJexIIzPvuu5LwT+cs1HO4/EsHfn2zfz8iHvIu/cX9bMvjgfEe90PcRZh7hb8B1jxqvLatAbu2RzL4pC7zg/cCNP6+RnyvPUSzNB1ecD4QWep9+g0p3EeX3eyicowtAvma+WsP9T5MKS7JGLqwSd1i2Adw05U6cmDryzUrickQTuNt8oInGd6mtn/w6wW88caydYEBuKHn8P+de8D+VIhdOdi1b6L+vnlslPgzuOB+oo/hJujmwfRy88dZdlv2GyMMU9EY7J8HbpTqaA+q4UPluzfBRmgIfq6cOdBZ6wibnuiGKWz16/PlNPHJmOsqLH8an5SZx56SQb+rXD+ZiAFdS7txpPbJ0oe/J3HXrCMXPzA8kFzpj7F+6OooHbK5T6mpFLq8gJcPKBh659K/N8a3If/6ouuHKDj59kDoQX+gTxzKVrDnBdxdH8Fb3cS50aWKygJ4bfGyA99ypUOSxikbXLvCCB84nMha6W5ZGMr8AeLOaagH/T46FntoXEWxH8SSftSvFPiBXfpJWUs8Hzj6f6FnoCvmTAX084O7d7PQ/lJFf+KE/vo5y/ae9PrrYDrIv9BjpgLP+XOBR84myhX7RtWr/qqUU/+ZlKHAGuY310Lgb5f4GfBPmvsqEXN+AITOO8nwE5xORC91B2SI5gBU8Ion5dn4m8ktSKXTdS8BTMpu/uUki76Jr4wiheNx8InfR8jl4Ytr/bhXrQl8peJcpj1I/Uu85nFx2AHldtxjd2t/gMvOJblQ+Ha7NpI2Bi8SqetfTIX/Vvom8cpDS/utWSD4sYEHx7bEdFqmU+v90fiJhoWslVnpfbAfXHJJv2CyHvDElK3WiHvy7e2jXvxzmhb5+wDVNpQ58/fxEDOqfT9i+GfgAfulKeEh1NHJa+9jMwWIj6oq8TU0v2TEP/JvcW6NROuRaLTFbtN+Bv52f6FromeWUAAl81lBxO0cMcovPl+TePgf3tTk20uqFXMCbzbUyAdzZ8cL5C6uRb/IyYP9wG1xjfiJxoe98stYh9Ba4zsSja2+nliza/11oJtddG0H+5WlQgtJFcItnf4y2+SJPO37bfdQLvGh+IhbFb2wnBf1dwfl+8QoLMyGnxRcrEzXYZMoYF3pZXqy4kBV4U7vkze5I5Cos2YFtJuAG8xPd6P57FsmkaIPfKlEUTRZFTouvHmxu+1pWzIDKX9FL1q/y4EnmG9b0PUU+EGj8clQWvG5+oQDq33pvTi/hpcSPd01/R2gjp8WvTn6HT0VN0y/0wUp6Dt3f4EcLXazSepG3fWVqFR8Bt5hfiLHQP/sn20e3giukBQfHByKnxe9uNZaiAzuR78pd8e1nDviQn5vUppXIt2Q90cx4SRkfzC9kQe2nm+6I4wNwiXM3HvkXIKeNX9zH7dk2X0PuKRpPPAihjK9uD2zItkVef5HLTNsD3G5+IdBCNzNX8aynjL8OuprkSCxDThu/yZwseX9sei53gfso7zJlMgAXjhDkqY1C/k5n5ZE/euARv5+52oQgp41P97KO7nrGi1x6I4++2GrwY5xv7YLHZhe6q8Vgr4woeCM1fkGe/txpSScz+McMu+KnZshp4/PElFW8vJLIZVe2abcPgx+cX4i20IdM1KeG+sAV1zia+uUgb0vujWSvBmdrtihI34Gclp9Y43dByHcN8t836yOzisFHXLm7zaSR37oSPaFRCN5LjW+Qmx/zOhlLyb/8uXtUKSl4eqHT8jsN21sf7tuDfI9RyMqMAPAN345ljcz+W+hJTlHFHUfBnXV1NwncRk7LX+kyJJh+jECuH6Mt+uEQuJfmDMk7FHnBowaGzxbgY33UhZTo+89LVJpvpuTX7O/9PC+InJa/q/bnONk3PLXQn5cHrffkBz8zv5B0oe//UuL/mhdcqvKT96dE5GknluWXcYNfqypskIpHTstPSgeGXfxqiZzpgUptwhB4tnWL1vPNyE1yVlsrVIHPnKIupF3ow2az+pdKwC9aLE1LqUROy89GiM1J5ZYgz/O0WqGTB851535YZibyT8ylhUQ8uKmppniKNXJa/vnFmo6dyhrIX/x99qXiLHiITpiJ0u/Jha7J6vx5lpL/ZrmRsn5XH3Ja/rxaRV19Lgf5W7Imk7AJuPU121C2u8gHuV+r8cuD79jr0/TKEDltfkD7rtHHLTuR54R8WnVsDbhKv3pury5yw9EjI1dWgrPPL9Re6P6tAzay/5ZB/6KdkZA++2eh0+Y/1h6OfE76iXyIw9de5RP4FcLc52Ef8oba5zo298HHJsRNuYqQ0+Z3JoUncvtTkV8we2VrbAneyJG+rjgGuYb8AabP+uC7efsvOYUip81PVWWQ4znskVdciXdaNcEF8eeMvnKQPnLNru16w5/Bq14cD5rZipw2/8bg+6S4VBw543S58dWb4Pu7xds4uJDb6n5rLTsKvjP7+o01f3+j9vF/5w+DB9OkQ8eQO1829NyxFbx4TfTpiwPIJ4a385HGl5KJs43u23OqkNPmR12yU0uPlSF/tzz2y1wbeIRr87/eIuTqKc0Cc5T5W6H5jQwLfTWHScw7ig+TTvlsxk6b/2Xpuzeigj3J7j1LCsV3rflZvwH7lb9sWp6S4IbLlsxcPoecNr99WzJRxMMb+Uxjl0nhUvBoB878ndjNJUZ6MzI5oX4yDaeVeyGnzc+T++s9pM8iv5TQc0DyEXgm262Us9iLHzs5HjYBv+Hg0Uj4IKetP8js07YtxN75YpvNDRL4bH5oCK8vcrq7gjs3fucgE2+ENW4cx/eHtn6irqnebDP2uF3JZzKawIcelCfsxT6n5Tt6Mhi8dKm4Sq4rctr6j9zkMtM9bsir3Y++Uj0FnvB2vSWbO/LnZYaDw6LgQhcO+jPg30db37Jra8zpKj/8/qIbazXYwQWI0N+9F5DfOy4gZ/OMnUwciU7N97qJnLY+Z2xH8GwbdpvlTWYySeCNepwO6reQexnZnLGJZF+0fvAlFsecoKw/uta9a43QC+S09UsKTU0qPC+RX5NNW+qhAX5FNOeU6yvktxhOb3jXx0YmHtZE2XPh+k1bf3VBZcfo6Qrk7wVmc+/UgjN8nevirkZel/yenu4iuMd3FceOfuS09WO90vlvO4eQL1GaNaU/DD7CfrY2/xfyR+9Cy3bIgWfGD+1MF0DtJ2193OthQ4Pzq5FHPdvDJNrHSibK455o3Sch9/NQueheC77s36olsruQ09b36c7uC1l6GHnvN4d4Dg/wa9reytpeyOmF8zR+ngIXOGsX6+ONnLY+8UwwT0ZzJHIfl5GHlYLgIw2CrHQJyDdp/Q1qnGIhEyaWf7NUU5DT1mfamJ+OYM1GLvjbPSksE3zn8Vcd78uRO57YUJlxEfyyekT7WCdy2vrSsEPc9FzjyAMGDo6xHQYffdqeQ8zg/jM9ia+Psv517Lbcn4DtKD6hrY/ldLY2uoNddYPMdBLFX+r4v0zF/mjPegd5ii8S/+zx0PdKS2MmE0uL7thfPI+ctj54ewYxORCGnJHdQtAkFHzrp++rBXF855R+6me6JbijdsbyQ/nIaeubO+jPH1FtRf7zELNINmV9dDBXskXSLHKu8aLulwzgww9vXGdjxPHx/67fPvClv65iFfIguUs6z5LBs+g39ifrIPfjUPV9cAn8aPcxxr2WyGnrz1vYPmvtc0Fuwd9Tv8YMfHaFyDerIOSzwgk3WDnB3TZt/ESfjpy2vp7HbN+5kffIPfoGRPdOLyETtp9zyvIKkN93Sv51qWvJouOTM6znM/Qegx/ouMm4hxONb2j7B3gicoazBJHbm8aL+YeCNzel0h2VRd5uruSqbwI+HNH9iM8UOW3/w3LtoN+sJ5BLiYa3BDGBT2me0blxFbnZy4KaA9OMMD5zf9Mncgc5bf8Gc9TLhL25yDmvN7V8fwQedTaykfcL8gEPkyL7APDvhzsajBnR+JW2P6V25135AVHkB5YwcEmZgOcm5To/kUPuGsmo1z/LAOXHL5Ip1h05bX9NoqwvedYDufofJyPfafB1QwPrGk8jbzTW0XaZZFh0fC70K0rO/TFl/5EVq71TLnLa/qHXzfSWElXI07OtvbV9wauM77gfb0M+zZQk074HXEpglO8DA8pf0PY/hWzRS26WQh6c0bDn7jQ9jO/MZf6L2o2cdTnH9lWT4FHWdg+l9yKn7e/6w9Elb+6FnF+Pzzj4Mbg9S6LWQCzys9x3OqrcwRsFblmWliCn7U97sN5lruET8jM9lWciTMF7Bpc+rehBbvzlwCCrCP2i+aEzK5/fk52lg+8/Ls77TRE5bf/d1CrzYpFNyF+b1VrTj4L/Cte6unkb8lauVzZWSeCHwt52uJ9FTts/6Pp8OoslEjnH+EsXFyfwR4nKlwvTkKt63eg8ZAae9fjDLY1C5FcOa994u45u0fwdbX9kv+qDtF8DyHdWnq0MnJsjEc4Ng55hXCg/uF3u9urMavCjd8lqplLIafs/r253M2vZitwn5cnB86bgpctqrUmmyEvCtAY31cySiEN2zoNxAchp+1f/ef17syMc+4GWuDsPwRu73yaqXkVOTf8ZgTObnd7b9QJ5WDqvb7Mu5f3/d36VYfvB5wZ/ZkhE1nKdsN1NyGn7d5251BmOtSPXa0p0j60GdzCXEBTtR+7yd2rDGwPwi5yslt1iKD9M25/8qV328LKNyLdcHOsaLJ8mERH+DJ7pu5Hbb9unFHsX3IlNW9DOBjltf7WHS8VQRBDy0tqhtaUT/0jE8qTJD36Pkf83fdCdtQR8VvxBeF4mctr+8F9klx1bW5BnphikmeqBT7RsSTAdQf5m6anIq3lTJMJSy7fsNB/K39P2xz/NuPWGWxg50/0puUN3wHPvRK3jFUP+0uQ4g7EF+CLzB31PhI3Mxv+SCOHO8RdfNZDT9v///U8mLl0Tufev7/uG3oOLrci+R9qJXMgkUKRNG7yw4F6X0RHktPML+h+zvLntgFzqm25GeO4k1I8xic+5Z5BfdbU29o0BzxLP8az2Q047f0Hul5J682Xk6veC7kysApeab8gW+oYu7q8fu/+QiI9lrwj6O8gTkyMZmUvBZ8aj1znGI6edL/HAkVWs6jly1+BzV6aVwC8l2Vxgy0T++M3mA4MffpOIgGeJ7ollyGnnY6hkh4YeqUVutVvlNZsf+PBz6yW/PiGX2xB+fKT5F9TPn0uZi8aQ0873OClxK5N1AvlaYxEDsSpwlYHg6S/Yw6ws7Xqegi8yf+Zu8VJKVBT8r6KtasEyNP9GO79EwC6Z9Sof8k1bpMYnun+SCIYXqiLdwsglVoTcCXAAl1D25mNbh5x2Pstk0m7dKhXk/RaD9x9//0EimszXMhlrIh+TftRcnQ7u6Nr2YoMBctr5MlbM5OTL5sjXKF1O4GUGF8tgat/ngPyWfFP2oYkJEpG0cyok0wk57XyckODIPqPTyKeYquq8jcGPV4S63DmPvJfYKjTKBP612LRKPxQ57Xyf693bymcjkT/bLXd9yXXwK9Q/kJMj5R1WioJzn1ohopaInHZ+UfQhrbuHk5Ar9BWK5beDX5Zk8bv3DHlcsljmfkXwLYJDx2QKkNPOXwptfS+Vjz3F+1CC7yrwi+O9x7YUIt+Z4JbTyAS+yPyzleSIkUfrCIm4UJBn9KkFOe18KbMwXlXNNuQ/IoX4hYPBj+ZkvOTpxPfvt+ngQedhEjHkkD67ehw57XysIykGs8Rv5IEhWn7Xng6RCGmWI7c9ZnD54F3K/mh6kEQUvDQfe8qK5u9p53ud2KUgq8mNPCNfi7jz4TuJCH++PJd3OXKdnEvL1kaAdxdafDKQRE47n4x1ON2rcjVyL3tbFeOt4PzzA4GFHvT06TYPbnDvX/I1xuuRKwkMfShmBbcoX/L8Hnba+W0/M5Qnf23G7zfND1575SuJKA+aamAhI58qWjv1Qxf875v7qnJ4/QPt/DnfKDu+KX3kn/821XTwgYvwl3/O24281MNeRjqwj0TcvE/Ofb0POe38vPKNJ9O6rJD3/4rr0b32hUTEGo2Wmh5GLnaYaOnJ6yURv8c9GX7bI6ed/xc2ZbryuTNyT5bKXTGC4K08+p1Np5Dv1pDdUDzbTSJ6S1rdZb2R084v7GV+9NrWB/nYrpyHJTfAuceCh3f7IQ8Qb730eFsXiai9vb3P/DJy2vmLg5LpVhLhyJ2uvJj+KwyuV1PwrxQ7B7X+dpCIwO8RDt54/cs+K0J1JhJ8kfUx4SK6XD/WtpOIkYsaKx/dQk47f/Jt6phqC/bvwvGZwwzgbQ5zLdy3kd9vCjljy90K/bvblcOSDxapXy0k4lVVi1Ia9miNhG1B98H/9v5r3PUQuWL5C3/9X40komJtfNDm5EXKN7jrWLEy/zN8fdemtrzXBn9nKn1aMgV5XmcTvWJTPYn49n2IOerlIuUP/P6r7TW+r5BfiFZ0aRv4SCIMhD8yZb1G7rez3Vokoxb6lwtu5KTMRcoH+Lki5w3fs/D6p/wTzf6SH6B9+LYrSOs9cpO5SztOKFfC+KW8pv553iL3v5xEGIaHjygWIK874vPR4GQZiYjLLGWoLET+8OSBD4kTRdA+8CnYvy5d5P4UQvvYxXBiuAzX/8GWe5r5+SQiv6q55GQFcv3L6i22e7IhPj0rtF2nepHrz4TxK/PE4zPYtTxzbvQcSScRe77yuyRhn7MnJ2o4pJGIZmmxg/GLfX4SiTg1Jcp3G3vJhU6mHa33SYTODQlmlhrk2rkfi9mvhsH3z1wbkMbvp/ufF1H+sPq1Mvj/A+ndrWo="];

and this is how it looks like

Graphics[Line[points], Frame -> True]

enter image description here

and then I use J. M.'s method(code copied and modified from here) (it will take about 10 seconds to run)

parametrizeCurve[pts_List, a : (_?NumericQ) : 1/2] := 
 FoldList[Plus, 0, Normalize[(Norm /@ Differences[pts])^a, Total]] /; 
  MatrixQ[pts, NumericQ]

tvals = parametrizeCurve[points];

m = 3;
knots = Join[ConstantArray[0, m + 1], MovingAverage[ArrayPad[tvals, -1], m], ConstantArray[1, m + 1]];
bas = Table[BSplineBasis[{m, knots}, j - 1, tvals[[i]]], {i, Length[points]}, {j, Length[points]}];
ctrlpts = LinearSolve[bas, points];

circPoints = {{1, 0}, {1, 1}, {-1, 1}, {-1, 0}, {-1, -1}, {1, -1}, {1,0}};
circKnots = {0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1};
circWts = {1, 1/2, 1/2, 1, 1/2, 1/2, 1};

wgpts = Map[Function[pt, Append[#1 pt, #2]], circPoints] & @@@ ctrlpts;
wgwts = ConstantArray[circWts, Length[ctrlpts]];

and then generate the 3d surface

Graphics3D[{Directive[EdgeForm[]], 
  BSplineSurface[wgpts, SplineClosed -> {False, True}, 
   SplineDegree -> {3, 2}, SplineKnots -> {knots, circKnots}, 
   SplineWeights -> wgwts]}, Boxed -> False]

enter image description here

We can see that the surface is not smooth. It looks like the surface is composed by flat rings. So how can we make the surface smooth?

Edit:

I think this unsmoothness may come from my data rather than the rotation process, so I tried to smooth my data using something like

pointsSmooth=ExponentialMovingAverage[points, 1/20];

then I get the a smoother surface, but ExponentialMovingAverage seems to have removed the end points and there is a hole on the surface, which I don't want.

enter image description here

Also smoothing using a smooth constant like 1/20 largely modified the original data:

Graphics[{Red, Line[ExponentialMovingAverage[points, 1/20]], Blue, 
  Line[points]}, Frame -> True, AspectRatio -> 1]

enter image description here

So is it possible to smooth the data while keep the general shape so that it will give a better smooth surface? Or there are other ways to contract a smooth surface from the data?

$\endgroup$
4
  • $\begingroup$ Now that you found the source of the lack of smoothness lies in your data, it is not clear what your question is now. $\endgroup$
    – m_goldberg
    May 29, 2014 at 4:21
  • $\begingroup$ @m_goldberg Still, my goal is get a smooth surface :) $\endgroup$ May 29, 2014 at 4:37
  • $\begingroup$ Why is it so important to avoid the small deviation between the actual data and approximate surface? $\endgroup$
    – Jens
    May 29, 2014 at 16:57
  • $\begingroup$ @Jens What did you refer to deviation, the roughness (discontinuity in the derivative) at the surface or the change of the curve after ExponentialMovingAverage? 1) If it's the later. I'm trying to make a movie of the wave function evolution by plotting the isosurface, when an atom is experiencing a laser field. since it's a physical simulation, I would like to make it looks good but also keep the data as unmodified as possible. 2) About the roughness, I generate the data and then rendered in povray. This roughness is more visible in the rendered image and is very annoying. $\endgroup$ May 29, 2014 at 17:17

3 Answers 3

9
$\begingroup$

Sounds like what you actually need after your edit is a way to smooth a list of data while keeping the endpoints fixed. Here's a dumb approach that will work with any "symmetrical" smoothing filter, including GaussianFilter, MeanFilter, even MedianFilter. It won't work with ExponentialMovingAverage, though, because that's not symmetrical, although it should if you average the results from ExponentialMovingAverage and Reverse@ExponentialMovingAverage@Reverse.

smooth[list_, filter_] := 
 Take[filter[Join[
    (2 First@list - #) & /@ Reverse@Rest@list, 
    list,
    (2 Last@list - #) & /@ Reverse@Most@list]],
  {Length@list, 2 Length@list - 1}]

All it does is it extends the data in a "flipped" form about both endpoints -- for example, $[1,2,10]$ will become $[\color{grey}{-8,0},1,2,10,\color{grey}{18,19}]$ -- then smooths that, and drops the extra entries.

For example:

smooth[{a, b, c, d, e}, GaussianFilter[#, 1] &] // Simplify
{a, 
 (b BesselI[0, 1/4] + (a + c) BesselI[1, 1/4])/(BesselI[0, 1/4] + 2 BesselI[1, 1/4]), 
 (c BesselI[0, 1/4] + (b + d) BesselI[1, 1/4])/(BesselI[0, 1/4] + 2 BesselI[1, 1/4]), 
 (d BesselI[0, 1/4] + (c + e) BesselI[1, 1/4])/(BesselI[0, 1/4] + 2 BesselI[1, 1/4]), 
 e}

:)


Turns out GaussianSmooth smooths across all dimensions of the array by default, so the $x$-coordinate gets averaged with the $y$-coordinate and vice versa. Oops.

{xs, ys} = smooth[#, GaussianFilter[#, 5] &] & /@ Transpose[points];
{fx, fy} = Interpolation /@ {xs, ys};
RevolutionPlot3D[{fx[i], fy[i]}, {i, 1, Length[points]}]

enter image description here

You can set smoothedPoints = Transpose@{xs, ys} if you want to use the whole parametrizeCurve stuff instead.

$\endgroup$
5
  • $\begingroup$ I don't know where I messed up but I can't make it work using your method. The smoothed curve seems dramatically changes. Could you give more details and show a plot? $\endgroup$ May 29, 2014 at 19:02
  • $\begingroup$ @xslittlegrass: Fixed. $\endgroup$
    – user484
    May 30, 2014 at 3:11
  • $\begingroup$ Still, downsampling the data through a spline fit, as in your answer, is probably a more sensible approach since you don't really need to retain all those hundreds of degrees of freedom. $\endgroup$
    – user484
    May 30, 2014 at 4:13
  • $\begingroup$ Thanks a lot for your answer! Your method is simpler and works very well. $\endgroup$ May 30, 2014 at 4:39
  • $\begingroup$ It looks more expedient to use ArrayPad[]: smooth[list_, filter_] := With[{n = Length[list]}, Take[filter[ArrayPad[list, n - 1, "Extrapolated", InterpolationOrder -> 1]], {n, 2 n - 1}]] $\endgroup$ Mar 12, 2018 at 12:57
9
$\begingroup$

The the roughness on the surface is due to the noise in the original data, so that the first derivative is not smooth.

This shows the first derivative of the x and y components using original data, we can see it's very noisy

tvals = parametrizeCurve[points];  
m = 3;
knots = Join[ConstantArray[0, m + 1], 
   MovingAverage[ArrayPad[tvals, -1], m], ConstantArray[1, m + 1]];
bas = Table[
   BSplineBasis[{m, knots}, j - 1, tvals[[i]]], {i, 
    Length[points]}, {j, Length[points]}];
ctrlpts = LinearSolve[bas, points];  


df1[u_] = 
  Evaluate@D[
    BSplineFunction[ctrlpts, SplineDegree -> 3, SplineKnots -> knots][
     u], u]; 
Plot[{Evaluate[df1[u]], Evaluate[df1[u]][[2]]}, {u, 0, 1}]

enter image description here

We need to remove that noise in order to get a smooth surface. This can be achieved using linear fit. Andy Ross presented very effective a spline model fit at here. I modified his code and create this function to apply to my 2d data.

dataSmoothSplineMethod[ls_?(ArrayQ[#, 1] &), knotNum_Integer] := 
 Module[{SplineModel, lth = Length[ls], knots, data},
  data = Transpose[{Range[1, lth], ls}];
  SplineModel[data_, deg_, knots_] := 
   Block[{basis, allKnots, n, kmin, kmax}, n = Length[knots] + 2;
    kmin = 0;
    kmax = Ceiling[Max[data[[All, 1]]]] + 1;
    basis = 
     Array[\[FormalX]^# &, deg + 1, 0]~Join~
      Table[BSplineBasis[{deg, knots}, i, \[FormalX]], {i, 0, 
        Length[knots] - deg - 2}];
    LinearModelFit[data, basis, \[FormalX]]];
  knots = {1}~Join~Range[2, lth - 1, Round[lth/(knotNum - 2)]]~
    Join~{lth};
  SplineModel[data, 3, knots]
  ]

dataSmoothSplineMethod[ls_?(ArrayQ[#, 2] &), knotNum_Integer] := 
 Module[{SplineModel, lth = Length[ls], lsx, lsy},
  lsx = ls[[All, 1]];
  lsy = ls[[All, 2]];
  {dataSmoothSplineMethod[lsx, knotNum], 
   dataSmoothSplineMethod[lsy, knotNum]}
  ]


f2 = dataSmoothSplineMethod[points, 20];

and here shows the comparison of the smoothed data and original data, we can the changes are almost not visible

Legended[Show[
  ParametricPlot[Through@f2[x], {x, 1, Length[points]}, 
   PlotPoints -> 100, PlotStyle -> Red], 
  Graphics[{Blue, Line[points]}]], 
 Placed[LineLegend[{Red, Blue}, {"spline fit", "original data"}], 
  ImageScaled@{0.5, 0.5}]]

enter image description here

but the first derivative is much more smooth

df2[u_] = {D[f2[[1]][u], u], D[f2[[2]][u], u]};

Plot[Evaluate[df2[u]], {u, 1, Length[points]}]

enter image description here

Using this smoothed data, we can create a much more smooth 3d surface

pointsSmoothed = Table[Through@f2[x], {x, 1, Length[points]}];
parametrizeCurve[pts_List, a : (_?NumericQ) : 1/2] := 
 FoldList[Plus, 0, Normalize[(Norm /@ Differences[pts])^a, Total]] /; 
  MatrixQ[pts, NumericQ]
tvals = parametrizeCurve[pointsSmoothed];
m = 3;
knots = Join[ConstantArray[0, m + 1], 
   MovingAverage[ArrayPad[tvals, -1], m], ConstantArray[1, m + 1]];
bas = Table[
   BSplineBasis[{m, knots}, j - 1, tvals[[i]]], {i, 
    Length[pointsSmoothed]}, {j, Length[pointsSmoothed]}];
ctrlpts = LinearSolve[bas, pointsSmoothed];
circpointsSmoothed = {{1, 0}, {1, 1}, {-1, 1}, {-1, 
    0}, {-1, -1}, {1, -1}, {1, 0}};
circKnots = {0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1};
circWts = {1, 1/2, 1/2, 1, 1/2, 1/2, 1};
wgpts = Map[Function[pt, Append[#1 pt, #2]], circpointsSmoothed] & @@@
    ctrlpts;
wgwts = ConstantArray[circWts, Length[ctrlpts]];

Graphics3D[{Directive[EdgeForm[]], 
  BSplineSurface[wgpts, SplineClosed -> {False, True}, 
   SplineDegree -> {3, 2}, SplineKnots -> {knots, circKnots}, 
   SplineWeights -> wgwts]}, Boxed -> False]

enter image description here

$\endgroup$
7
$\begingroup$

You have a lot of points, so generating two interpolation functions from them, one for the bottom of the surface and the other for the top, should give a smooth surface of revolution. If the default plot isn't smooth enough, you can always increase PlotPoints.

max = Max[First /@ points];
ii = Position[points, {max, _}][[1, 1]];
btm = Interpolation[points[[;; ii]]];
top = Interpolation[points[[ii ;;]]];
RevolutionPlot3D[{{t, btm[t]}, {t, top[t]}}, {t, 0., max}]

plot

$\endgroup$
1
  • $\begingroup$ Thanks, but it doesn't seems to work well even I increased the PlotPoints to 100. Here is the result I get imgur.com/t61hEW8 $\endgroup$ May 29, 2014 at 15:24

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.